packages feed

cabal-install 1.24.0.2 → 2.0.0.0

raw patch · 348 files changed

+32468/−20066 lines, 348 filesdep +deepseqdep +echodep +edit-distancedep −regex-posixdep ~Cabaldep ~HTTPdep ~Win32setup-changed

Dependencies added: deepseq, echo, edit-distance, pretty-show, tracetree

Dependencies removed: regex-posix

Dependency ranges changed: Cabal, HTTP, Win32, array, async, base, base16-bytestring, binary, bytestring, bytestring-builder, containers, cryptohash-sha256, directory, filepath, hackage-security, hashable, mtl, network, network-uri, old-time, pretty, process, random, stm, tar, time, unix, zlib

Files

Distribution/Client/BuildReports/Anonymous.hs view
@@ -27,18 +27,18 @@   ) where  import qualified Distribution.Client.Types as BR-         ( BuildResult, BuildFailure(..), BuildSuccess(..)+         ( BuildOutcome, BuildFailure(..), BuildResult(..)          , DocsResult(..), TestsResult(..) ) import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) import qualified Paths_cabal_install (version)  import Distribution.Package-         ( PackageIdentifier(..), PackageName(..) )+         ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )---import Distribution.Version---         ( Version )+         ( FlagName, mkFlagName, unFlagName, FlagAssignment )+import Distribution.Version+         ( mkVersion' ) import Distribution.System          ( OS, Arch ) import Distribution.Compiler@@ -120,7 +120,7 @@   deriving Eq  new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment-    -> [PackageIdentifier] -> BR.BuildResult -> BuildReport+    -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport new os' arch' comp pkgid flags deps result =   BuildReport {     package               = pkgid,@@ -145,21 +145,22 @@       Left  (BR.BuildFailed     _) -> BuildFailed       Left  (BR.TestsFailed     _) -> TestsFailed       Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildOk       _ _ _) -> InstallOk+      Right (BR.BuildResult _ _ _) -> InstallOk     convertDocsOutcome = case result of-      Left _                                -> NotTried-      Right (BR.BuildOk BR.DocsNotTried _ _)  -> NotTried-      Right (BR.BuildOk BR.DocsFailed _ _)    -> Failed-      Right (BR.BuildOk BR.DocsOk _ _)        -> Ok+      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.BuildOk _ BR.TestsNotTried _) -> NotTried-      Right (BR.BuildOk _ BR.TestsOk _)       -> Ok+      Left  (BR.TestsFailed _)                    -> Failed+      Left _                                      -> NotTried+      Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried+      Right (BR.BuildResult _ BR.TestsOk _)       -> Ok  cabalInstallID :: PackageIdentifier cabalInstallID =-  PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version+  PackageIdentifier (mkPackageName "cabal-install")+                    (mkVersion' Paths_cabal_install.version)  -- ------------------------------------------------------------ -- * External format@@ -263,15 +264,15 @@ sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs  dispFlag :: (FlagName, Bool) -> Disp.Doc-dispFlag (FlagName name, True)  =                  Disp.text name-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name+dispFlag (fname, True)  =                  Disp.text (unFlagName fname)+dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname)  parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do   name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')   case name of-    ('-':flag) -> return (FlagName flag, False)-    flag       -> return (FlagName flag, True)+    ('-':flag) -> return (mkFlagName flag, False)+    flag       -> return (mkFlagName flag, True)  instance Text.Text InstallOutcome where   disp PlanningFailed  = Disp.text "PlanningFailed"
Distribution/Client/BuildReports/Storage.hs view
@@ -28,10 +28,12 @@  import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.ComponentDeps as CD 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@@ -103,7 +105,7 @@         fromPathTemplate (substPathTemplate env template)       where env = initialPathTemplateEnv                     (BuildReport.package  report)-                    -- ToDo: In principle, we can support $pkgkey, but only+                    -- 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.@@ -121,38 +123,35 @@  fromInstallPlan :: Platform -> CompilerId                 -> InstallPlan+                -> BuildOutcomes                 -> [(BuildReport, Maybe Repo)]-fromInstallPlan platform comp plan =+fromInstallPlan platform comp plan buildOutcomes =      catMaybes-   . map (fromPlanPackage platform comp)+   . map (\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 planPackage = case planPackage of-  InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ _) deps)-                         _ result-    -> Just $ ( BuildReport.new os arch comp-                                (packageId srcPkg) flags-                                (map packageId (CD.nonSetupDeps deps))-                                (Right result)-              , extractRepo srcPkg)--  InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result-    -> Just $ ( BuildReport.new os arch comp-                                (packageId srcPkg) flags-                                (map confSrcId (CD.nonSetupDeps deps))-                                (Left result)-              , extractRepo srcPkg )--  _ -> Nothing-+fromPlanPackage (Platform arch os) comp+                (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))+                (Just buildResult) =+      Just ( BuildReport.new os arch comp+                             (packageId srcPkg) flags+                             (map packageId (CD.nonSetupDeps deps))+                             buildResult+           , extractRepo srcPkg)   where     extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })                   = Just repo     extractRepo _ = Nothing++fromPlanPackage _ _ _ _ = Nothing+  fromPlanningFailure :: Platform -> CompilerId     -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
Distribution/Client/BuildReports/Upload.hs view
@@ -25,7 +25,7 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display) import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die)+import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup          ( RepoContext(..) )@@ -48,7 +48,7 @@   res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)   case res of     (303, redir) -> return $ undefined redir --TODO parse redir-    _ -> die "unrecognized response" -- give response+    _ -> die' verbosity "unrecognized response" -- give response  {-   setAllowRedirects False@@ -89,4 +89,4 @@   res <- postHttp transport verbosity fullURI buildLog (Just auth)   case res of     (200, _) -> return ()-    _ -> die "unrecognized response" -- give response+    _ -> die' verbosity "unrecognized response" -- give response
− Distribution/Client/BuildTarget.hs 
@@ -1,1623 +0,0 @@-{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.BuildTargets--- Copyright   :  (c) Duncan Coutts 2012, 2015--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org------ Handling for user-specified build targets-------------------------------------------------------------------------------module Distribution.Client.BuildTarget (--    -- * Build targets-    BuildTarget(..),-    --showBuildTarget,-    QualLevel(..),-    buildTargetPackage,-    buildTargetComponentName,--    -- * Top level convenience-    readUserBuildTargets,-    resolveUserBuildTargets,--    -- * Parsing user build targets-    UserBuildTarget,-    parseUserBuildTargets,-    showUserBuildTarget,-    UserBuildTargetProblem(..),-    reportUserBuildTargetProblems,--    -- * Resolving build targets-    resolveBuildTargets,-    BuildTargetProblem(..),-    reportBuildTargetProblems,-  ) where--import Distribution.Package-         ( Package(..), PackageId, PackageName, packageName )-import Distribution.Client.Types-         ( PackageLocation(..) )--import Distribution.PackageDescription-         ( PackageDescription-         , Executable(..)-         , TestSuite(..), TestSuiteInterface(..), testModules-         , Benchmark(..), BenchmarkInterface(..), benchmarkModules-         , BuildInfo(..), libModules, exeModules )-import Distribution.ModuleName-         ( ModuleName, toFilePath )-import Distribution.Simple.LocalBuildInfo-         ( Component(..), ComponentName(..)-         , pkgComponents, componentName, componentBuildInfo )--import Distribution.Text-         ( display, simpleParse )-import Distribution.Simple.Utils-         ( die, lowercase )-import Distribution.Client.Utils-         ( makeRelativeToCwd )--import Data.List-         ( nub, nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )-import Data.Maybe-         ( listToMaybe, maybeToList )-import Data.Either-         ( partitionEithers )-import Data.Function-         ( on )-import GHC.Generics (Generic)-#if MIN_VERSION_containers(0,5,0)-import qualified Data.Map.Lazy   as Map.Lazy-import qualified Data.Map.Strict as Map-import Data.Map.Strict (Map)-#else-import qualified Data.Map as Map.Lazy-import qualified Data.Map as Map-import Data.Map (Map)-#endif-import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..), (<$>))-#endif-import Control.Applicative (Alternative(..))-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP-         ( (+++), (<++) )-import Data.Char-         ( isSpace, isAlphaNum )-import System.FilePath as FilePath-         ( takeExtension, dropExtension, addTrailingPathSeparator-         , splitDirectories, joinPath, splitPath )-import System.Directory-         ( doesFileExist, doesDirectoryExist, canonicalizePath-         , getCurrentDirectory )-import System.FilePath-         ( (</>), (<.>), normalise )----- --------------------------------------------------------------- * User build targets--- ---------------------------------------------------------------- | Various ways that a user may specify a build target.------ The main general form has lots of optional parts:------ > [ package name | package dir | package .cabal file ]--- > [ [lib:|exe:] component name ]--- > [ module name | source file ]------ There's also a special case of a package tarball. It doesn't take part in--- the main general form since we always build a tarball package as a whole.------ > [package tar.gz file]----data UserBuildTarget =--     -- | A simple target specified by a single part. This is any of the-     -- general forms that can be expressed using one part, which are:-     ---     -- > cabal build foo                      -- package name-     -- > cabal build ../bar ../bar/bar.cabal  -- package dir or package file-     -- > cabal build foo                      -- component name-     -- > cabal build Data.Foo                 -- module name-     -- > cabal build Data/Foo.hs bar/Main.hsc -- file name-     ---     -- It can also be a package tarball.-     ---     -- > cabal build bar.tar.gz-     ---     UserBuildTarget1 String--     -- | A qualified target with two parts. This is any of the general-     -- forms that can be expressed using two parts, which are:-     ---     -- > cabal build foo:foo              -- package : component-     -- > cabal build foo:Data.Foo         -- package : module-     -- > cabal build foo:Data/Foo.hs      -- package : filename-     ---     -- > cabal build ./foo:foo            -- package dir : component-     -- > cabal build ./foo:Data.Foo       -- package dir : module-     ---     -- > cabal build ./foo.cabal:foo      -- package file : component-     -- > cabal build ./foo.cabal:Data.Foo -- package file : module-     -- > cabal build ./foo.cabal:Main.hs  -- package file : filename-     ---     -- > cabal build lib:foo exe:foo      -- namespace : component-     -- > cabal build foo:Data.Foo         -- component : module-     -- > cabal build foo:Data/Foo.hs      -- component : filename-     ---   | UserBuildTarget2 String String--     -- A (very) qualified target with three parts. This is any of the general-     -- forms that can be expressed using three parts, which are:-     ---     -- > cabal build foo:lib:foo          -- package : namespace : component-     -- > cabal build foo:foo:Data.Foo     -- package : component : module-     -- > cabal build foo:foo:Data/Foo.hs  -- package : component : filename-     ---     -- > cabal build foo/:lib:foo         -- pkg dir : namespace : component-     -- > cabal build foo/:foo:Data.Foo    -- pkg dir : component : module-     -- > cabal build foo/:foo:Data/Foo.hs -- pkg dir : component : filename-     ---     -- > cabal build foo.cabal:lib:foo         -- pkg file : namespace : component-     -- > cabal build foo.cabal:foo:Data.Foo    -- pkg file : component : module-     -- > cabal build foo.cabal:foo:Data/Foo.hs -- pkg file : component : filename-     ---     -- > cabal build lib:foo:Data.Foo     -- namespace : component : module-     -- > cabal build lib:foo:Data/Foo.hs  -- namespace : component : filename-     ---   | UserBuildTarget3 String String String--     -- A (rediculously) qualified target with four parts. This is any of the-     -- general forms that can be expressed using all four parts, which are:-     ---     -- > cabal build foo:lib:foo:Data.Foo     -- package : namespace : component : module-     -- > cabal build foo:lib:foo:Data/Foo.hs  -- package : namespace : component : filename-     ---     -- > cabal build foo/:lib:foo:Data.Foo    -- pkg dir : namespace : component : module-     -- > cabal build foo/:lib:foo:Data/Foo.hs -- pkg dir : namespace : component : filename-     ---     -- > cabal build foo.cabal:lib:foo:Data.Foo    -- pkg file : namespace : component : module-     -- > cabal build foo.cabal:lib:foo:Data/Foo.hs -- pkg file : namespace : component : filename-     ---   | UserBuildTarget4 String String String String-  deriving (Show, Eq, Ord)----- --------------------------------------------------------------- * Resolved build targets--- ---------------------------------------------------------------- | A fully resolved build target.----data BuildTarget pkg =--     -- | A package as a whole -     ---     BuildTargetPackage pkg--     -- | A specific component-     ---   | BuildTargetComponent pkg ComponentName--     -- | A specific module within a specific component.-     ---   | BuildTargetModule pkg ComponentName ModuleName--     -- | A specific file within a specific component.-     ---   | BuildTargetFile pkg ComponentName FilePath-  deriving (Eq, Ord, Functor, Show, Generic)----- | Get the package that the 'BuildTarget' is referring to.----buildTargetPackage :: BuildTarget pkg -> pkg-buildTargetPackage (BuildTargetPackage   p)         = p-buildTargetPackage (BuildTargetComponent p _cn)     = p-buildTargetPackage (BuildTargetModule    p _cn _mn) = p-buildTargetPackage (BuildTargetFile      p _cn _fn) = p----- | Get the 'ComponentName' that the 'BuildTarget' is referring to, if any.--- The 'BuildTargetPackage' target kind doesn't refer to any individual--- component, while the component, module and file kinds do.----buildTargetComponentName :: BuildTarget pkg -> Maybe ComponentName-buildTargetComponentName (BuildTargetPackage   _p)        = Nothing-buildTargetComponentName (BuildTargetComponent _p cn)     = Just cn-buildTargetComponentName (BuildTargetModule    _p cn _mn) = Just cn-buildTargetComponentName (BuildTargetFile      _p cn _fn) = Just cn----- --------------------------------------------------------------- * Top level, do everything--- ----------------------------------------------------------------- | Parse a bunch of command line args as user build targets, failing with an--- error if any targets are unrecognised.----readUserBuildTargets :: [String] -> IO [UserBuildTarget]-readUserBuildTargets targetStrs = do-    let (uproblems, utargets) = parseUserBuildTargets targetStrs-    reportUserBuildTargetProblems uproblems-    return utargets----- | A 'UserBuildTarget's is just a semi-structured string. We sill have quite--- a bit of work to do to figure out which targets they refer to (ie packages,--- components, file locations etc).------ The possible targets are based on the available packages (and their--- locations). It fails with an error if any user string cannot be matched to--- a valid target.----resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)]-                        -> [UserBuildTarget] -> IO [BuildTarget PackageName]-resolveUserBuildTargets pkgs utargets = do-    utargets' <- mapM getUserTargetFileStatus utargets-    pkgs'     <- mapM (uncurry selectPackageInfo) pkgs-    pwd       <- getCurrentDirectory-    let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'-        (bproblems,  btargets)  = resolveBuildTargets-                                    primaryPkg otherPkgs utargets''-        -- default local dir target if there's no given target-        utargets''-          | not (null primaryPkg)-          , null utargets       = [UserBuildTargetFileStatus1 "./"-                                     (FileStatusExistsDir pwd)]-          | otherwise           = utargets'--    reportBuildTargetProblems bproblems-    return (map (fmap packageName) btargets)-  where-    selectPrimaryLocalPackage :: FilePath-                              -> [PackageInfo]-                              -> ([PackageInfo], [PackageInfo])-    selectPrimaryLocalPackage pwd pkgs' =-        let (primary, others) = partition isPrimary pkgs'-         in (primary, others)-      where-        isPrimary PackageInfo { pinfoDirectory = Just (dir,_) }-          | dir == pwd = True-        isPrimary _    = False----- --------------------------------------------------------------- * Checking if targets exist as files--- --------------------------------------------------------------data UserBuildTargetFileStatus =-     UserBuildTargetFileStatus1 String FileStatus-   | UserBuildTargetFileStatus2 String FileStatus String-   | UserBuildTargetFileStatus3 String FileStatus String String-   | UserBuildTargetFileStatus4 String FileStatus 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)--getUserTargetFileStatus :: UserBuildTarget -> IO UserBuildTargetFileStatus-getUserTargetFileStatus t =-    case t of-      UserBuildTarget1 s1 ->-        (\f1 -> UserBuildTargetFileStatus1 s1 f1)          <$> fileStatus s1-      UserBuildTarget2 s1 s2 ->-        (\f1 -> UserBuildTargetFileStatus2 s1 f1 s2)       <$> fileStatus s1-      UserBuildTarget3 s1 s2 s3 ->-        (\f1 -> UserBuildTargetFileStatus3 s1 f1 s2 s3)    <$> fileStatus s1-      UserBuildTarget4 s1 s2 s3 s4 ->-        (\f1 -> UserBuildTargetFileStatus4 s1 f1 s2 s3 s4) <$> fileStatus s1-  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-        _           -> error "getUserTargetFileStatus: empty path"--forgetFileStatus :: UserBuildTargetFileStatus -> UserBuildTarget-forgetFileStatus t = case t of-    UserBuildTargetFileStatus1 s1 _          -> UserBuildTarget1 s1-    UserBuildTargetFileStatus2 s1 _ s2       -> UserBuildTarget2 s1 s2-    UserBuildTargetFileStatus3 s1 _ s2 s3    -> UserBuildTarget3 s1 s2 s3-    UserBuildTargetFileStatus4 s1 _ s2 s3 s4 -> UserBuildTarget4 s1 s2 s3 s4----- --------------------------------------------------------------- * Parsing user targets--- ----------------------------------------------------------------- | Parse a bunch of 'UserBuildTarget's (purely without throwing exceptions).----parseUserBuildTargets :: [String] -> ([UserBuildTargetProblem]-                                     ,[UserBuildTarget])-parseUserBuildTargets = partitionEithers . map parseUserBuildTarget--parseUserBuildTarget :: String -> Either UserBuildTargetProblem-                                         UserBuildTarget-parseUserBuildTarget targetstr =-    case readPToMaybe parseTargetApprox targetstr of-      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)-      Just tgt -> Right tgt--  where-    parseTargetApprox :: Parse.ReadP r UserBuildTarget-    parseTargetApprox =-          (do a <- tokenQ-              return (UserBuildTarget1 a))-      +++ (do a <- tokenQ-              _ <- Parse.char ':'-              b <- tokenQ-              return (UserBuildTarget2 a b))-      +++ (do a <- tokenQ-              _ <- Parse.char ':'-              b <- tokenQ-              _ <- Parse.char ':'-              c <- tokenQ-              return (UserBuildTarget3 a b c))-      +++ (do a <- tokenQ-              _ <- Parse.char ':'-              b <- token-              _ <- Parse.char ':'-              c <- tokenQ-              _ <- Parse.char ':'-              d <- tokenQ-              return (UserBuildTarget4 a b c d))--    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')-    tokenQ = parseHaskellString <++ token-    parseHaskellString :: Parse.ReadP r String-    parseHaskellString = Parse.readS_to_P reads--    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                         , all isSpace s ]---- | Syntax error when trying to parse a 'UserBuildTarget'.-data UserBuildTargetProblem-   = UserBuildTargetUnrecognised String-  deriving Show---- | Throw an exception with a formatted message if there are any problems.----reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()-reportUserBuildTargetProblems problems = do-    case [ target | UserBuildTargetUnrecognised target <- problems ] of-      []     -> return ()-      target ->-        die $ unlines-                [ "Unrecognised build target syntax for '" ++ name ++ "'."-                | name <- target ]-           ++ "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)\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"----- | Render a 'UserBuildTarget' back as the external syntax. This is mainly for--- error messages.----showUserBuildTarget :: UserBuildTarget -> String-showUserBuildTarget = intercalate ":" . components-  where-    components (UserBuildTarget1 s1)          = [s1]-    components (UserBuildTarget2 s1 s2)       = [s1,s2]-    components (UserBuildTarget3 s1 s2 s3)    = [s1,s2,s3]-    components (UserBuildTarget4 s1 s2 s3 s4) = [s1,s2,s3,s4]--showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String-showBuildTarget ql = showUserBuildTarget . forgetFileStatus-                   . head . renderBuildTarget ql----- --------------------------------------------------------------- * Resolving user targets to build targets--- ----------------------------------------------------------------- | Given a bunch of user-specified targets, try to resolve what it is they--- refer to.----resolveBuildTargets :: [PackageInfo]     -- any primary pkg, e.g. cur dir-                    -> [PackageInfo]     -- all the other local packages-                    -> [UserBuildTargetFileStatus]-                    -> ([BuildTargetProblem], [BuildTarget PackageInfo])-resolveBuildTargets ppinfo opinfo =-    partitionEithers-  . map (resolveBuildTarget ppinfo opinfo)--resolveBuildTarget :: [PackageInfo] -> [PackageInfo]-                   -> UserBuildTargetFileStatus-                   -> Either BuildTargetProblem (BuildTarget PackageInfo)-resolveBuildTarget ppinfo opinfo userTarget =-    case findMatch (matcher userTarget) of-      Unambiguous          target  -> Right target-      None                 errs    -> Left (classifyMatchErrors errs)-      Ambiguous exactMatch targets ->-        case disambiguateBuildTargets-               matcher userTarget exactMatch-               targets of-          Right targets'   -> Left (BuildTargetAmbiguous  userTarget' targets')-          Left ((m, ms):_) -> Left (MatchingInternalError userTarget' m ms)-          Left []          -> internalError "resolveBuildTarget"-  where-    matcher = matchBuildTarget ppinfo opinfo--    userTarget' = forgetFileStatus userTarget--    classifyMatchErrors errs-      | not (null expected)-      = let (things, got:_) = unzip expected in-        BuildTargetExpected userTarget' things got--      | not (null nosuch)-      = BuildTargetNoSuch userTarget' nosuch--      | otherwise-      = internalError $ "classifyMatchErrors: " ++ show errs-      where-        expected = [ (thing, got) -                   | (_, MatchErrorExpected thing got)-                           <- map (innerErr Nothing) errs ]-        nosuch   = [ (inside, thing, got, alts)-                   | (inside, MatchErrorNoSuch thing got alts)-                           <- map (innerErr Nothing) errs ]--        innerErr _ (MatchErrorIn kind thing m)-                     = innerErr (Just (kind,thing)) m-        innerErr c m = (c,m)----- | The various ways that trying to resolve a 'UserBuildTarget' to a--- 'BuildTarget' can fail.----data BuildTargetProblem-   = BuildTargetExpected   UserBuildTarget [String]  String-     -- ^  [expected thing] (actually got)-   | BuildTargetNoSuch     UserBuildTarget-                           [(Maybe (String, String), String, String, [String])]-     -- ^ [([in thing], no such thing,  actually got, alternatives)]-   | BuildTargetAmbiguous  UserBuildTarget-                           [(UserBuildTarget, BuildTarget PackageInfo)]--   | MatchingInternalError UserBuildTarget (BuildTarget PackageInfo)-                           [(UserBuildTarget, [BuildTarget PackageInfo])]---disambiguateBuildTargets-  :: (UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo))-  -> UserBuildTargetFileStatus -> Bool-  -> [BuildTarget PackageInfo]-  -> Either [(BuildTarget PackageInfo,-              [(UserBuildTarget, [BuildTarget PackageInfo])])]-            [(UserBuildTarget, BuildTarget PackageInfo)]-disambiguateBuildTargets 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.-    matchResultsRenderings :: [(BuildTarget PackageInfo, [UserBuildTargetFileStatus])]-    matchResultsRenderings =-      [ (matchResult, matchRenderings)-      | matchResult <- matchResults-      , let matchRenderings =-              [ rendering-              | ql <- [QL1 .. QL4]-              , rendering <- renderBuildTarget 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 UserBuildTargetFileStatus-                           (Match (BuildTarget PackageInfo))-    memoisedMatches =-        -- avoid recomputing the main one if it was an exact match-        (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults)-                       else id)-      $ Map.Lazy.fromList-          [ (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 (BuildTarget PackageInfo,-                        [(UserBuildTarget, [BuildTarget PackageInfo])])-                       (UserBuildTarget, BuildTarget PackageInfo)]-    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 (ExactMatch _ matches) =-                            memoisedMatches Map.! rendering -                    ] )--      | (originalMatch, matchRenderings) <- matchResultsRenderings ]--    findUnambiguous :: BuildTarget PackageInfo -> [UserBuildTargetFileStatus]-                    -> Maybe UserBuildTargetFileStatus-    findUnambiguous _ []     = Nothing-    findUnambiguous t (r:rs) =-      case memoisedMatches Map.! r of-        ExactMatch _ [t'] | fmap packageName t == fmap packageName t'-                         -> Just r-        ExactMatch _  _  -> findUnambiguous t rs-        InexactMatch _ _ -> internalError "InexactMatch"-        NoMatch      _ _ -> internalError "NoMatch"--internalError :: String -> a-internalError msg =-  error $ "BuildTargets: internal error: " ++ msg---data QualLevel = QL1 | QL2 | QL3 | QL4-  deriving (Enum, Show)--renderBuildTarget :: QualLevel -> BuildTarget PackageInfo-                  -> [UserBuildTargetFileStatus]-renderBuildTarget ql t =-    case t of-      BuildTargetPackage p ->-        case ql of-          QL1 -> [t1 (dispP p)]-          QL2 -> [t1' pf fs | (pf, fs) <- dispPF p]-          QL3 -> []-          QL4 -> []--      BuildTargetComponent p c ->-        case ql of-          QL1 -> [t1                     (dispC p c)]-          QL2 -> [t2 (dispP p)           (dispC p c),-                  t2           (dispK c) (dispC p c)]-          QL3 -> [t3 (dispP p) (dispK c) (dispC p c)]-          QL4 -> []--      BuildTargetModule p c m ->-        case ql of-          QL1 -> [t1                                 (dispM m)]-          QL2 -> [t2 (dispP p)                       (dispM m),-                  t2                     (dispC p c) (dispM m)]-          QL3 -> [t3 (dispP p)           (dispC p c) (dispM m),-                  t3           (dispK c) (dispC p c) (dispM m)]-          QL4 -> [t4 (dispP p) (dispK c) (dispC p c) (dispM m)]--      BuildTargetFile p c f ->-        case ql of-          QL1 -> [t1                                 f]-          QL2 -> [t2 (dispP p)                       f,-                  t2                     (dispC p c) f]-          QL3 -> [t3 (dispP p)           (dispC p c) f,-                  t3           (dispK c) (dispC p c) f]-          QL4 -> [t4 (dispP p) (dispK c) (dispC p c) f]-  where-    t1  s1 = UserBuildTargetFileStatus1 s1 none-    t1' s1 = UserBuildTargetFileStatus1 s1-    t2  s1 = UserBuildTargetFileStatus2 s1 none-    t3  s1 = UserBuildTargetFileStatus3 s1 none-    t4  s1 = UserBuildTargetFileStatus4 s1 none-    none   = FileStatusNotExists False--    dispP = display . packageName-    dispC = componentStringName . packageName-    dispK = showComponentKindShort . componentKind-    dispM = display--    dispPF p = [ (addTrailingPathSeparator drel, FileStatusExistsDir dabs)-               | PackageInfo { pinfoDirectory   = Just (dabs,drel) } <- [p] ]-            ++ [ (frel, FileStatusExistsFile fabs)-               | PackageInfo { pinfoPackageFile = Just (fabs,frel) } <- [p] ]----- | Throw an exception with a formatted message if there are any problems.----reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()-reportBuildTargetProblems problems = do--    case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of-      [] -> return ()-      ((target, originalMatch, renderingsAndMatches):_) ->-        die $ "Internal error in build target matching. It should always be "-           ++ "possible to find a syntax that's sufficiently qualified to "-           ++ "give an unambigious match. However when matching '"-           ++ showUserBuildTarget target ++ "'  we found "-           ++ showBuildTarget QL1 originalMatch-           ++ " (" ++ showBuildTargetKind originalMatch ++ ") which does not "-           ++ "have an unambigious syntax. The possible syntax and the "-           ++ "targets they match are as follows:\n"-           ++ unlines-                [ "'" ++ showUserBuildTarget rendering ++ "' which matches "-                  ++ intercalate ", "-                       [ showBuildTarget QL1 match ++-                         " (" ++ showBuildTargetKind match ++ ")"-                       | match <- matches ]-                | (rendering, matches) <- renderingsAndMatches ]--    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [    "Unrecognised build target '" ++ showUserBuildTarget target-            ++ "'.\n"-            ++ "Expected a " ++ intercalate " or " expected-            ++ ", rather than '" ++ got ++ "'."-          | (target, expected, got) <- targets ]--    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [ "Unknown build target '" ++ showUserBuildTarget target ++-            "'.\n" ++ unlines-            [    (case inside of-                    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, take 10 alts) --TODO: select best ones-                    | (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) | BuildTargetAmbiguous t ts <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [    "Ambiguous build target '" ++ showUserBuildTarget target-            ++ "'. It could be:\n "-            ++ unlines [ "   "++ showUserBuildTarget ut ++-                         " (" ++ showBuildTargetKind bt ++ ")"-                       | (ut, bt) <- amb ]-          | (target, amb) <- targets ]--  where-    showBuildTargetKind (BuildTargetPackage   _    ) = "package"-    showBuildTargetKind (BuildTargetComponent _ _  ) = "component"-    showBuildTargetKind (BuildTargetModule    _ _ _) = "module"-    showBuildTargetKind (BuildTargetFile      _ _ _) = "file"---------------------------------------- Top level BuildTarget matcher-----matchBuildTarget :: [PackageInfo] -> [PackageInfo]-                 -> UserBuildTargetFileStatus-                 -> Match (BuildTarget PackageInfo)-matchBuildTarget ppinfo opinfo = \utarget ->-    nubMatchesBy ((==) `on` (fmap packageName)) $-    case utarget of-      UserBuildTargetFileStatus1 str1 fstatus1 ->-        matchBuildTarget1 ppinfo opinfo str1 fstatus1--      UserBuildTargetFileStatus2 str1 fstatus1 str2 ->-        matchBuildTarget2 pinfo str1 fstatus1 str2--      UserBuildTargetFileStatus3 str1 fstatus1 str2 str3 ->-        matchBuildTarget3 pinfo str1 fstatus1 str2 str3--      UserBuildTargetFileStatus4 str1 fstatus1 str2 str3 str4 ->-        matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4-  where-    pinfo  = ppinfo ++ opinfo-    --TODO: sort this out---matchBuildTarget1 :: [PackageInfo] -> [PackageInfo]-                  -> String -> FileStatus -> Match (BuildTarget PackageInfo)-matchBuildTarget1 ppinfo opinfo = \str1 fstatus1 ->-         match1Cmp pcinfo str1-    <//> match1Pkg pinfo  str1 fstatus1-    <//> match1Cmp ocinfo str1-    <//> match1Mod cinfo  str1-    <//> match1Fil pinfo  str1 fstatus1-  where-    pinfo  = ppinfo ++ opinfo-    cinfo  = concatMap pinfoComponents pinfo-    pcinfo = concatMap pinfoComponents ppinfo-    ocinfo = concatMap pinfoComponents opinfo---matchBuildTarget2 :: [PackageInfo] -> String -> FileStatus -> String-                  -> Match (BuildTarget PackageInfo)-matchBuildTarget2 pinfo str1 fstatus1 str2 =-        match2PkgCmp pinfo str1 fstatus1 str2-   <|>  match2KndCmp cinfo str1          str2-   <//> match2PkgMod pinfo str1 fstatus1 str2-   <//> match2CmpMod cinfo str1          str2-   <//> match2PkgFil pinfo str1 fstatus1 str2-   <//> match2CmpFil cinfo str1          str2-  where-    cinfo = concatMap pinfoComponents pinfo-    --TODO: perhaps we actually do want to prioritise local/primary components---matchBuildTarget3 :: [PackageInfo] -> String -> FileStatus -> String -> String-                  -> Match (BuildTarget PackageInfo)-matchBuildTarget3 pinfo str1 fstatus1 str2 str3 =-        match3PkgKndCmp pinfo str1 fstatus1 str2 str3 -   <//> match3PkgCmpMod pinfo str1 fstatus1 str2 str3-   <//> match3PkgCmpFil pinfo str1 fstatus1 str2 str3-   <//> match3KndCmpMod cinfo str1          str2 str3-   <//> match3KndCmpFil cinfo str1          str2 str3-  where-    cinfo = concatMap pinfoComponents pinfo---matchBuildTarget4 :: [PackageInfo]-                  -> String -> FileStatus -> String -> String -> String-                  -> Match (BuildTarget PackageInfo)-matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 =-        match4PkgKndCmpMod pinfo str1 fstatus1 str2 str3 str4-   <//> match4PkgKndCmpFil pinfo str1 fstatus1 str2 str3 str4------------------------------------------ Individual BuildTarget matchers-----match1Pkg :: [PackageInfo] -> String -> FileStatus-          -> Match (BuildTarget PackageInfo)-match1Pkg pinfo = \str1 fstatus1 -> do-    guardPackage            str1 fstatus1-    p <- matchPackage pinfo str1 fstatus1-    return (BuildTargetPackage p)--match1Cmp :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo)-match1Cmp cs = \str1 -> do-    guardComponentName str1-    c <- matchComponentName cs str1-    return (BuildTargetComponent (cinfoPackage c) (cinfoName c))--match1Mod :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo)-match1Mod cs = \str1 -> do-    guardModuleName str1-    let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]-    (m,c) <- matchModuleNameAnd ms str1-    return (BuildTargetModule (cinfoPackage c) (cinfoName c) m)--match1Fil :: [PackageInfo] -> String -> FileStatus-          -> Match (BuildTarget PackageInfo)-match1Fil ps str1 fstatus1 =-    expecting "file" str1 $ do-    (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile-      return (BuildTargetFile p (cinfoName c) filepath)-------match2PkgCmp :: [PackageInfo]-             -> String -> FileStatus -> String-             -> Match (BuildTarget PackageInfo)-match2PkgCmp ps = \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    guardComponentName   str2-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      return (BuildTargetComponent p (cinfoName c))-    --TODO: the error here ought to say there's no component by that name in-    -- this package, and name the package--match2KndCmp :: [ComponentInfo] -> String -> String-             -> Match (BuildTarget PackageInfo)-match2KndCmp cs = \str1 str2 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    return (BuildTargetComponent (cinfoPackage c) (cinfoName c))--match2PkgMod :: [PackageInfo] -> String -> FileStatus -> String-             -> Match (BuildTarget PackageInfo)-match2PkgMod ps = \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    guardModuleName      str2-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ]-      (m,c) <- matchModuleNameAnd ms str2-      return (BuildTargetModule p (cinfoName c) m)--match2CmpMod :: [ComponentInfo] -> String -> String-             -> Match (BuildTarget PackageInfo)-match2CmpMod cs = \str1 str2 -> do-    guardComponentName str1-    guardModuleName    str2-    c <- matchComponentName cs str1-    orNoThingIn "component" (cinfoStrName c) $ do-      let ms = cinfoModules c-      m <- matchModuleName ms str2-      return (BuildTargetModule (cinfoPackage c) (cinfoName c) m)--match2PkgFil :: [PackageInfo] -> String -> FileStatus -> String-             -> Match (BuildTarget PackageInfo)-match2PkgFil ps str1 fstatus1 str2 = do-    guardPackage         str1 fstatus1-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      (filepath, c) <- matchComponentFile (pinfoComponents p) str2-      return (BuildTargetFile p (cinfoName c) filepath)--match2CmpFil :: [ComponentInfo] -> String -> String-             -> Match (BuildTarget PackageInfo)-match2CmpFil cs str1 str2 = do-    guardComponentName str1-    c <- matchComponentName cs str1-    orNoThingIn "component" (cinfoStrName c) $ do-      (filepath, _) <- matchComponentFile [c] str2-      return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath)-------match3PkgKndCmp :: [PackageInfo]-                -> String -> FileStatus -> String -> String-                -> Match (BuildTarget PackageInfo)-match3PkgKndCmp ps = \str1 fstatus1 str2 str3 -> do-    guardPackage         str1 fstatus1-    ckind <- matchComponentKind str2-    guardComponentName   str3-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str3-      return (BuildTargetComponent p (cinfoName c))--match3PkgCmpMod :: [PackageInfo]-                -> String -> FileStatus -> String -> String-                -> Match (BuildTarget PackageInfo)-match3PkgCmpMod ps = \str1 fstatus1 str2 str3 -> do-    guardPackage str1 fstatus1-    guardComponentName str2-    guardModuleName    str3-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      orNoThingIn "component" (cinfoStrName c) $ do-        let ms = cinfoModules c-        m <- matchModuleName ms str3-        return (BuildTargetModule p (cinfoName c) m)--match3KndCmpMod :: [ComponentInfo]-                -> String -> String -> String-                -> Match (BuildTarget PackageInfo)-match3KndCmpMod cs = \str1 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 (BuildTargetModule (cinfoPackage c) (cinfoName c) m)--match3PkgCmpFil :: [PackageInfo]-                -> String -> FileStatus -> String -> String-                -> Match (BuildTarget PackageInfo)-match3PkgCmpFil ps = \str1 fstatus1 str2 str3 -> do-    guardPackage         str1 fstatus1-    guardComponentName   str2-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentName (pinfoComponents p) str2-      orNoThingIn "component" (cinfoStrName c) $ do-        (filepath, _) <- matchComponentFile [c] str3-        return (BuildTargetFile p (cinfoName c) filepath)--match3KndCmpFil :: [ComponentInfo] -> String -> String -> String-                -> Match (BuildTarget PackageInfo)-match3KndCmpFil cs = \str1 str2 str3 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    orNoThingIn "component" (cinfoStrName c) $ do-      (filepath, _) <- matchComponentFile [c] str3-      return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath)------match4PkgKndCmpMod :: [PackageInfo]-                   -> String-> FileStatus -> String -> String -> String-                   -> Match (BuildTarget PackageInfo)-match4PkgKndCmpMod ps = \str1 fstatus1 str2 str3 str4 -> do-    guardPackage         str1 fstatus1-    ckind <- matchComponentKind str2-    guardComponentName   str3-    guardModuleName      str4-    p <- matchPackage ps str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str3-      orNoThingIn "component" (cinfoStrName c) $ do-        let ms = cinfoModules c-        m <- matchModuleName ms str4-        return (BuildTargetModule p (cinfoName c) m)--match4PkgKndCmpFil :: [PackageInfo]-                   -> String -> FileStatus -> String -> String -> String-                   -> Match (BuildTarget PackageInfo)-match4PkgKndCmpFil ps = \str1 fstatus1 str2 str3 str4 -> do-    guardPackage       str1 fstatus1-    ckind <- matchComponentKind str2-    guardComponentName str3-    p     <- matchPackage ps    str1 fstatus1-    orNoThingIn "package" (display (packageName p)) $ do-      c <- matchComponentKindAndName (pinfoComponents p) ckind str3-      orNoThingIn "component" (cinfoStrName c) $ do-        (filepath,_) <- matchComponentFile [c] str4-        return (BuildTargetFile p (cinfoName c) filepath)------------------------------------- Package and component info-----data PackageInfo = PackageInfo {-       pinfoId          :: PackageId,-       pinfoLocation    :: PackageLocation (),-       pinfoDirectory   :: Maybe (FilePath, FilePath),-       pinfoPackageFile :: Maybe (FilePath, FilePath),-       pinfoComponents  :: [ComponentInfo]-     }--data ComponentInfo = ComponentInfo {-       cinfoName    :: ComponentName,-       cinfoStrName :: ComponentStringName,-       cinfoPackage :: PackageInfo,-       cinfoSrcDirs :: [FilePath],-       cinfoModules :: [ModuleName],-       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)-       cinfoCFiles  :: [FilePath],-       cinfoJsFiles :: [FilePath]-     }--type ComponentStringName = String--instance Package PackageInfo where-  packageId = pinfoId----TODO: [required eventually] need the original GenericPackageDescription or--- the flattening thereof because we need to be able to target modules etc--- that are not enabled in the current configuration.-selectPackageInfo :: PackageDescription -> PackageLocation a -> IO PackageInfo-selectPackageInfo pkg loc = do-    (pkgdir, pkgfile) <--      case loc of-        --TODO: local tarballs, remote tarballs etc-        LocalUnpackedPackage dir -> do -          dirabs <- canonicalizePath dir-          dirrel <- makeRelativeToCwd dirabs-          --TODO: ought to get this earlier in project reading-          let fileabs = dirabs </> display (packageName pkg) <.> "cabal"-              filerel = dirrel </> display (packageName pkg) <.> "cabal"-          exists <- doesFileExist fileabs-          return ( Just (dirabs, dirrel)-                 , if exists then Just (fileabs, filerel) else Nothing-                 )-        _ -> return (Nothing, Nothing)-    let pinfo =-          PackageInfo {-            pinfoId          = packageId pkg,-            pinfoLocation    = fmap (const ()) loc,-            pinfoDirectory   = pkgdir,-            pinfoPackageFile = pkgfile,-            pinfoComponents  = selectComponentInfo pinfo pkg-          }-    return pinfo---selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo]-selectComponentInfo pinfo pkg =-    [ ComponentInfo {-        cinfoName    = componentName c,-        cinfoStrName = componentStringName (packageName pkg) (componentName c),-        cinfoPackage = pinfo,-        cinfoSrcDirs = hsSourceDirs bi,---                       [ pkgroot </> srcdir---                       | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo)---                       , srcdir <- hsSourceDirs bi ],-        cinfoModules = componentModules c,-        cinfoHsFiles = componentHsFiles c,-        cinfoCFiles  = cSources bi,-        cinfoJsFiles = jsSources bi-      }-    | c <- pkgComponents pkg-    , let bi = componentBuildInfo c ]---componentStringName :: PackageName -> ComponentName -> ComponentStringName-componentStringName pkgname CLibName         = display pkgname-componentStringName _      (CExeName  name)  = name-componentStringName _      (CTestName  name) = name-componentStringName _      (CBenchName name) = name--componentModules :: Component -> [ModuleName]-componentModules (CLib   lib)   = libModules lib-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 component kinds-----data ComponentKind = LibKind | ExeKind | TestKind | BenchKind-  deriving (Eq, Ord, Show)--componentKind :: ComponentName -> ComponentKind-componentKind CLibName       = LibKind-componentKind (CExeName  _)  = ExeKind-componentKind (CTestName  _) = TestKind-componentKind (CBenchName _) = BenchKind--cinfoKind :: ComponentInfo -> ComponentKind-cinfoKind = componentKind . cinfoName--matchComponentKind :: String -> Match ComponentKind-matchComponentKind s-  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind-  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind-  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence-                                             >> return TestKind-  | s `elem` ["bench", "benchmark"]        = increaseConfidence-                                             >> return BenchKind-  | otherwise                              = matchErrorExpected-                                             "component kind" s--showComponentKind :: ComponentKind -> String-showComponentKind LibKind   = "library"-showComponentKind ExeKind   = "executable"-showComponentKind TestKind  = "test-suite"-showComponentKind BenchKind = "benchmark"--showComponentKindShort :: ComponentKind -> String-showComponentKindShort LibKind   = "lib"-showComponentKindShort ExeKind   = "exe"-showComponentKindShort TestKind  = "test"-showComponentKindShort BenchKind = "bench"----------------------------------- Matching package targets-----guardPackage :: String -> FileStatus -> Match ()-guardPackage str fstatus =-      guardPackageName str-  <|> guardPackageDir  str fstatus-  <|> guardPackageFile str fstatus---guardPackageName :: String -> Match ()-guardPackageName s-  | validPackgageName s = increaseConfidence-  | otherwise           = matchErrorExpected "package name" s-  where--validPackgageName :: String -> Bool-validPackgageName s =-       all validPackgageNameChar s-    && not (null s)-  where-    validPackgageNameChar 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 :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo-matchPackage pinfo = \str fstatus ->-    orNoThingIn "project" "" $-          matchPackageName pinfo str-    <//> (matchPackageDir  pinfo str fstatus-     <|>  matchPackageFile pinfo str fstatus)---matchPackageName :: [PackageInfo] -> String -> Match PackageInfo-matchPackageName ps = \str -> do-    guard (validPackgageName str)-    orNoSuchThing "package" str-                  (map (display . packageName) ps) $-      increaseConfidenceFor $-        matchInexactly caseFold (display . packageName) ps str---matchPackageDir :: [PackageInfo]-                -> String -> FileStatus -> Match PackageInfo-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@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ]---matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo-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@PackageInfo{ 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 :: [ComponentInfo] -> String -> Match ComponentInfo-matchComponentName cs str =-    orNoSuchThing "component" str (map cinfoStrName cs)-  $ increaseConfidenceFor-  $ matchInexactly caseFold cinfoStrName cs str---matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String-                          -> Match ComponentInfo-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 simpleParse 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 display ms)-  $ increaseConfidenceFor-  $ matchInexactly caseFold display ms str---matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)-matchModuleNameAnd ms str =-    orNoSuchThing "module" str (map (display . fst) ms)-  $ increaseConfidenceFor-  $ matchInexactly caseFold (display . fst) ms str------------------------------------ Matching file targets-----matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus-                            -> Match (FilePath, PackageInfo)-matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =-    increaseConfidenceFor $-      matchDirectoryPrefix pkgdirs filepath-  where-    pkgdirs = [ (dir, p)-              | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ]-matchPackageDirectoryPrefix _ _ = mzero---matchComponentFile :: [ComponentInfo] -> String-                   -> Match (FilePath, ComponentInfo)-matchComponentFile cs str =-    orNoSuchThing "file" str [] $-        matchComponentModuleFile cs str-    <|> matchComponentOtherFile  cs str---matchComponentOtherFile :: [ComponentInfo] -> String-                        -> Match (FilePath, ComponentInfo)-matchComponentOtherFile cs =-    matchFile-      [ (file, c)-      | c    <- cs-      , file <- cinfoHsFiles c-             ++ cinfoCFiles  c-             ++ cinfoJsFiles c-      ]---matchComponentModuleFile :: [ComponentInfo] -> String-                         -> Match (FilePath, ComponentInfo)-matchComponentModuleFile cs str = do-    matchFile-      [ (normalise (d </> toFilePath m), c)-      | c <- cs-      , d <- cinfoSrcDirs c-      , m <- cinfoModules c-      ]-      (dropExtension (normalise str))---- 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]-             | ExactMatch   Confidence [a]-             | InexactMatch Confidence [a]-  deriving Show--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 (ExactMatch   d xs) = ExactMatch   d (fmap f xs)-    fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)--instance Applicative Match where-    pure a = ExactMatch 0 [a]-    (<*>)  = ap--instance Alternative Match where-    empty = NoMatch 0 []-    (<|>) = matchPlus--instance Monad Match where-    return                  = pure-    NoMatch      d ms >>= _ = NoMatch d ms-    ExactMatch   d xs >>= f = addDepth d-                            $ msum (map f xs)-    InexactMatch d xs >>= f = addDepth d . forceInexact-                            $ msum (map f xs)--instance MonadPlus Match where-    mzero = empty-    mplus = matchPlus--(<//>) :: Match a -> Match a -> Match a-(<//>) = matchPlusShadowing--infixl 3 <//>--addDepth :: Confidence -> Match a -> Match a-addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs-addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs-addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs--forceInexact :: Match a -> Match a-forceInexact (ExactMatch d ys) = InexactMatch d ys-forceInexact m                 = m---- | 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.----matchPlus :: Match a -> Match a -> Match a-matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =-  ExactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a-matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a-matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =-  InexactMatch (max d1 d2) (xs ++ xs')-matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a-matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b-matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b-matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')-                                             | d1 >  d2  = a-                                             | d1 <  d2  = b-                                             | otherwise = NoMatch d1 (ms ++ ms')---- | 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.----matchPlusShadowing :: Match a -> Match a -> Match a-matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = 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 = ExactMatch 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 (ExactMatch   d xs)   = ExactMatch   d (nubBy eq xs)-nubMatchesBy eq (InexactMatch d xs)   = InexactMatch d (nubBy eq xs)--nubMatchErrors :: Match a -> Match a-nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)-nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs-nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs---- | Lift a list of matches to an exact match.----exactMatches, inexactMatches :: [a] -> Match a--exactMatches [] = mzero-exactMatches xs = ExactMatch 0 xs--inexactMatches [] = mzero-inexactMatches xs = InexactMatch 0 xs--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 nubMatchErrors match of-      NoMatch    _ msgs -> None msgs-      ExactMatch   _ [x] -> Unambiguous x-      InexactMatch _ [x] -> Unambiguous x-      ExactMatch   _  [] -> error "findMatch: impossible: ExactMatch []"-      InexactMatch _  [] -> error "findMatch: impossible: InexactMatch []"-      ExactMatch   _  xs -> Ambiguous True  xs-      InexactMatch _  xs -> Ambiguous False xs--data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [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------------------------------------ Utils-----caseFold :: String -> String-caseFold = lowercase------------------------------------ Example inputs-----{--ex1pinfo :: [PackageInfo]-ex1pinfo =-  [ PackageInfo {-      pinfoName        = PackageName "foo",-      pinfoDirectory   = Just "/the/foo",-      pinfoPackageFile = Just "/the/foo/foo.cabal",-      pinfoComponents  = []-    }-  , PackageInfo {-      pinfoName        = PackageName "bar",-      pinfoDirectory   = Just "/the/bar",-      pinfoPackageFile = Just "/the/bar/bar.cabal",-      pinfoComponents  = []-    }-  ]--}-{--stargets =-  [ BuildTargetComponent (CExeName "foo")-  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")-  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")-  ]-    where-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse--ex_pkgid :: PackageIdentifier-Just ex_pkgid = simpleParse "thelib"--}--{--ex_cs :: [ComponentInfo]-ex_cs =-  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])-  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])-  ]-    where-    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse-    pkgid :: PackageIdentifier-    Just pkgid = simpleParse "thelib"--}-
Distribution/Client/Check.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Check@@ -17,8 +18,12 @@  import Control.Monad ( when, unless ) -import Distribution.PackageDescription.Parse-         ( readPackageDescription )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )+#else+import Distribution.PackageDescription.Parse ( readGenericPackageDescription )+#endif+ import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )@@ -30,7 +35,7 @@ check :: Verbosity -> IO Bool check verbosity = do     pdfile <- defaultPackageDesc verbosity-    ppd <- readPackageDescription verbosity pdfile+    ppd <- readGenericPackageDescription verbosity pdfile     -- flatten the generic package description into a regular package     -- description     -- TODO: this may give more warnings than it should give;
+ Distribution/Client/CmdBench.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-}++-- | cabal-install CLI command: bench+--+module Distribution.Client.CmdBench (+    -- * The @bench@ CLI and action+    benchCommand,+    benchAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++import Control.Monad (when)+++benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+benchCommand = Client.installCommand {+  commandName         = "new-bench",+  commandSynopsis     = "Run benchmarks",+  commandUsage        = usageAlternatives "new-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 ++ " new-bench\n"+     ++ "    Run all the benchmarks in the package in the current directory\n"+     ++ "  " ++ pname ++ " new-bench pkgname\n"+     ++ "    Run all the benchmarks in the package named pkgname\n"+     ++ "  " ++ pname ++ " new-bench cname\n"+     ++ "    Run the benchmark named cname\n"+     ++ "  " ++ pname ++ " new-bench cname -O2\n"+     ++ "    Run the benchmark built with '-O2' (including local libs used)\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }+++-- | 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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+            -> [String] -> GlobalFlags -> IO ()+benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+            targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) 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+                         TargetProblemCommon+                         elaboratedPlan+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            return elaboratedPlan'++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++-- | 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 PackageId+                     -> [AvailableTarget k] -> Either TargetProblem [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 (TargetProblemNoBenchmarks 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 :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget pkgid cname subtarget@WholeComponent t+  | CBenchName _ <- availableTargetComponentName t+  = either (Left . TargetProblemCommon) return $+           selectComponentTargetBasic pkgid cname subtarget t+  | otherwise+  = Left (TargetProblemComponentNotBenchmark pkgid cname)++selectComponentTarget pkgid cname subtarget _+  = Left (TargetProblemIsSubComponent pkgid cname subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.+--+data TargetProblem =+     TargetProblemCommon        TargetProblemCommon++     -- | The 'TargetSelector' matches benchmarks but none are buildable+   | TargetProblemNoneEnabled  (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets    (TargetSelector PackageId)++     -- | The 'TargetSelector' matches targets but no benchmarks+   | TargetProblemNoBenchmarks (TargetSelector PackageId)++     -- | 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)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "run" problem++renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "benchmark" targetSelector targets++renderTargetProblem (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."++renderTargetProblem (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+  where+    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter+    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter+    targetSelectorFilter (TargetComponent _ _ _)       = Nothing++renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) =+    "The bench command is for running benchmarks, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ display pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderTargetProblem (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 view
@@ -1,32 +1,71 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}  -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild (+    -- * The @build@ CLI and action+    buildCommand,     buildAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget   ) where  import Distribution.Client.ProjectOrchestration-         ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets-         , ProjectBuildContext(..), runProjectBuildPhase-         , printPlan, reportBuildFailures )-import Distribution.Client.ProjectConfig-         ( BuildTimeSettings(..) )-import Distribution.Client.ProjectPlanning-         ( PackageTarget(..) )-import Distribution.Client.BuildTarget-         ( readUserBuildTargets )+import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity-         ( normal )+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die' ) -import Control.Monad (unless)+import qualified Data.Map as Map  +buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+buildCommand = Client.installCommand {+  commandName         = "new-build",+  commandSynopsis     = "Compile targets within the project.",+  commandUsage        = usageAlternatives "new-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 ++ " new-build\n"+     ++ "    Build the package in the current directory or all packages in the project\n"+     ++ "  " ++ pname ++ " new-build pkgname\n"+     ++ "    Build the package named pkgname in the project\n"+     ++ "  " ++ pname ++ " new-build ./pkgfoo\n"+     ++ "    Build the package in the ./pkgfoo directory\n"+     ++ "  " ++ pname ++ " new-build cname\n"+     ++ "    Build the component named cname in the project\n"+     ++ "  " ++ pname ++ " new-build cname --enable-profiling\n"+     ++ "    Build the component in profiling mode (including dependencies as needed)\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }++ -- | 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.@@ -36,35 +75,123 @@ -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)             -> [String] -> GlobalFlags -> IO ()-buildAction (configFlags, configExFlags, installFlags, haddockFlags)+buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))             targetStrings globalFlags = do -    userTargets <- readUserBuildTargets targetStrings+    baseCtx <- establishProjectBaseContext verbosity cliConfig -    buildCtx@ProjectBuildContext{buildSettings} <--      runProjectPreBuildPhase-        verbosity-        ( globalFlags, configFlags, configExFlags-        , installFlags, haddockFlags )-        PreBuildHooks {-          hookPrePlanning      = \_ _ _ -> return (),-          hookSelectPlanSubset = selectBuildTargets userTargets-        }+    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) targetStrings -    printPlan verbosity buildCtx+    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -    unless (buildSettingDryRun buildSettings) $ do-      plan <- runProjectBuildPhase-                verbosity-                buildCtx-      reportBuildFailures plan+            -- 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+                         TargetProblemCommon+                         elaboratedPlan+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            elaboratedPlan'' <-+              if buildSettingOnlyDeps (buildSettings baseCtx)+                then either (reportCannotPruneDependencies verbosity) return $+                     pruneInstallPlanToDependencies (Map.keysSet targets)+                                                    elaboratedPlan'+                else return elaboratedPlan'++            return elaboratedPlan''++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags -    -- When we interpret the targets on the command line, interpret them as-    -- repl targets (as opposed to say repl or haddock targets).-    selectBuildTargets =-      selectTargets-        BuildDefaultComponents-        BuildSpecificComponent+-- | 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 PackageId+                     -> [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 :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget pkgid cname subtarget =+    either (Left . TargetProblemCommon) Right+  . selectComponentTargetBasic pkgid cname subtarget+++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @build@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon++     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   (TargetSelector PackageId)+  deriving (Eq, Show)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "build" problem+renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "build" targetSelector targets+renderTargetProblem(TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets "build" targetSelector++reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a+reportCannotPruneDependencies verbosity =+    die' verbosity . renderCannotPruneDependencies
Distribution/Client/CmdConfigure.hs view
@@ -1,20 +1,71 @@+{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure (+    configureCommand,     configureAction,   ) where  import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig+         ( writeProjectLocalExtraConfig )  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults ) import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity          ( normal ) +import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText )+import qualified Distribution.Client.Setup as Client +configureCommand :: CommandUI (ConfigFlags, ConfigExFlags+                              ,InstallFlags, HaddockFlags)+configureCommand = Client.installCommand {+  commandName         = "new-configure",+  commandSynopsis     = "Add extra project configuration",+  commandUsage        = usageAlternatives "new-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 'new-build', 'new-repl' etc) though it "+     ++ "can be extended/overridden on a per-command basis.\n\n"++     ++ "The new-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 'new-clean' but is "+     ++ "overwritten on the next use of the 'new-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 'new-configure' command. It is "+     ++ "merely a convenience in cases where you do not want to specify flags "+     ++ "to 'new-build' (and other commands) every time and yet do not want "+     ++ "to alter the 'cabal.project' persistently.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-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 ++ " new-configure\n"+     ++ "    Reset the local configuration to empty and check the overall\n"+     ++ "    project configuration works.\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }+ -- | 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).@@ -27,34 +78,41 @@ -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)                 -> [String] -> GlobalFlags -> IO ()-configureAction (configFlags, configExFlags, installFlags, haddockFlags)+configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))                 _extraArgs globalFlags = do     --TODO: deal with _extraArgs, since flags with wrong syntax end up there +    baseCtx <- establishProjectBaseContext verbosity cliConfig++    -- Write out the @cabal.project.local@ so it gets picked up by the+    -- planning phase.+    writeProjectLocalExtraConfig (distDirLayout baseCtx)+                                 cliConfig+     buildCtx <--      runProjectPreBuildPhase-        verbosity-        ( globalFlags, configFlags, configExFlags-        , installFlags, haddockFlags )-        PreBuildHooks {-          hookPrePlanning = \projectRootDir _ cliConfig ->-            -- Write out the @cabal.project.local@ so it gets picked up by the-            -- planning phase.-            writeProjectLocalExtraConfig projectRootDir cliConfig,+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -          hookSelectPlanSubset = return-        }+            -- 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 -    --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-      buildCtx {-        buildSettings = (buildSettings buildCtx) {-          buildSettingDryRun = True-        }-      }+    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 configFlags configExFlags+                  installFlags haddockFlags
+ Distribution/Client/CmdErrorMessages.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++-- | 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.ProjectOrchestration+import Distribution.Client.TargetSelector+         ( componentKind, showTargetSelector )++import Distribution.Package+         ( packageId, packageName )+import Distribution.Types.ComponentName+         ( showComponentName )+import Distribution.Solver.Types.OptionalStanza+         ( OptionalStanza(..) )+import Distribution.Text+         ( display )++import Data.Maybe (isNothing)+import Data.List (sortBy, groupBy, nub)+import Data.Function (on)+++-----------------------+-- 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 " ++ display pkgname ++ " components "+-- >      ++ renderListCommaAnd showComponentName components+-- >   | (pkgname, components) <- sortGroupOn packageName allcomponents ]+--+sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]+sortGroupOn key = map (\xs@(x:_) -> (key x, xs))+                . groupBy ((==) `on` key)+                . sortBy  (compare `on` key)+++----------------------------------------------------+-- Renderering for a few project and package types+--++renderTargetSelector :: TargetSelector PackageId -> String+renderTargetSelector (TargetPackage _ pkgid Nothing) =+    "the package " ++ display pkgid++renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) =+    "the " ++ renderComponentKind Plural kfilter+ ++ " in the package " ++ display pkgid++renderTargetSelector (TargetAllPackages Nothing) =+    "all the packages in the project"++renderTargetSelector (TargetAllPackages (Just kfilter)) =+    "all the " ++ renderComponentKind Plural kfilter+ ++ " in the project"++renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) =+    "the library in the package " ++ display pkgid++renderTargetSelector (TargetComponent _pkgid cname WholeComponent) =+    "the " ++ showComponentName cname++renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) =+    "the file " ++ filename ++ " in the " ++ showComponentName cname++renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) =+    "the module " ++ display modname ++ " in the " ++ showComponentName cname+++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 a -> Plural+targetSelectorPluralPkgs (TargetAllPackages _)     = Plural+targetSelectorPluralPkgs (TargetPackage _ _ _)     = Singular+targetSelectorPluralPkgs (TargetComponent _ _ _)   = Singular++-- | Does the 'TargetSelector' refer to +targetSelectorRefersToPkgs :: TargetSelector a -> Bool+targetSelectorRefersToPkgs (TargetAllPackages  mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetPackage  _ _ mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetComponent _ _ _)       = False++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 TargetProblemCommon+--++renderTargetProblemCommon :: String -> TargetProblemCommon -> String+renderTargetProblemCommon verb (TargetNotInProject pkgname) =+    "Cannot " ++ verb ++ " the package " ++ display 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."++renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "+ ++ "package " ++ display 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."++renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "+ ++ "marked as 'buildable: False' within the '" ++ display (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."++renderTargetProblemCommon 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)++renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "+ ++ "solver did not find a plan that included the " ++ compkinds+ ++ " for " ++ display 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)++renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) =+    "Internal error when trying to " ++ verb ++ " the package "+  ++ display pkgid ++ ". The package is not in the set of available targets "+  ++ "for the project plan, which would suggest an inconsistency "+  ++ "between readTargetSelectors and resolveTargets."++renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) =+    "Internal error when trying to " ++ verb ++ " the "+  ++ showComponentName cname ++ " from the package " ++ display 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 PackageId+                               -> [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+        (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 PackageId -> 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 (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++-----------------------------------------------------------+-- 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 " ++ display pkgid ++ " is "+          _       -> "the packages "+                     ++ renderListCommaAnd (map display 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/CmdFreeze.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-}++-- | cabal-install CLI command: freeze+--+module Distribution.Client.CmdFreeze (+    freezeCommand,+    freezeAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..), ProjectConfigShared(..)+         , writeProjectLocalFreezeConfig )+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 )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( die', notice )+import Distribution.Verbosity+         ( normal )++import Data.Monoid as Monoid+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad (unless)++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Utils+         ( wrapText )+import qualified Distribution.Client.Setup as Client+++freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+freezeCommand = Client.installCommand {+  commandName         = "new-freeze",+  commandSynopsis     = "Freeze dependencies.",+  commandUsage        = usageAlternatives "new-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 'new-build', "+     ++ "'new-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 'new-build --dry-run' with "+     ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "+     ++ "a satisfactory solution to freeze it using the 'new-freeze' command "+     ++ "with the same set of flags.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-freeze\n"+     ++ "    Freeze the configuration of the current project\n\n"+     ++ "  " ++ pname ++ " new-build --dry-run --constraint=\"aeson < 1\"\n"+     ++ "    Check what a solution with the given constraints would look like\n"+     ++ "  " ++ pname ++ " new-freeze --constraint=\"aeson < 1\"\n"+     ++ "    Freeze a solution using the given constraints\n\n"++     ++ "Note: this command is part of the new project-based system (aka "+     ++ "nix-style\nlocal builds). These features are currently in beta. "+     ++ "Please see\n"+     ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "+     ++ "for\ndetails and advice on what you can expect to work. If you "+     ++ "encounter problems\nplease file issues at "+     ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "+     ++ "to get involved and help with testing, fixing bugs etc then\nthat "+     ++ "is very much appreciated.\n"+   }++-- | 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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+             -> [String] -> GlobalFlags -> IO ()+freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+             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++    (_, elaboratedPlan, _) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages++    let freezeConfig = projectFreezeConfig elaboratedPlan+    writeProjectLocalFreezeConfig distDirLayout freezeConfig+    notice verbosity $+      "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"++  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++++-- | Given the install plan, produce a config value with constraints that+-- freezes the versions of packages used in the plan.+--+projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig+projectFreezeConfig elaboratedPlan =+    Monoid.mempty {+      projectConfigShared = Monoid.mempty {+        projectConfigConstraints =+          concat (Map.elems (projectFreezeConstraints elaboratedPlan))+      }+    }++-- | 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 (UserQualified UserQualToplevel 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 (null 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 =+#if MIN_VERSION_containers(0,5,0)+      Map.mergeWithKey+        (\_pkgname () constraints ->+            case filter (not . isVersionConstraint . fst) constraints of+              []           -> Nothing+              constraints' -> Just constraints')+        (const Map.empty) id+        localPackages+#else+      Map.mapMaybeWithKey+        (\pkgname constraints ->+            if pkgname `Map.member` localPackages+              then case filter (not . isVersionConstraint . fst) constraints of+                     []           -> Nothing+                     constraints' -> Just constraints'+              else Just constraints)+#endif++    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 view
@@ -0,0 +1,200 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-}++-- | cabal-install CLI command: haddock+--+module Distribution.Client.CmdHaddock (+    -- * The @haddock@ CLI and action+    haddockCommand,+    haddockAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client+import Distribution.Simple.Setup+         ( HaddockFlags(..), fromFlagOrDefault, fromFlag )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++import Control.Monad (when)+++haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags+                            ,HaddockFlags)+haddockCommand = Client.installCommand {+  commandName         = "new-haddock",+  commandSynopsis     = "Build Haddock documentation",+  commandUsage        = usageAlternatives "new-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 ++ " new-haddock pkgname"+     ++ "    Build documentation for the package named pkgname\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }+   --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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+                 -> [String] -> GlobalFlags -> IO ()+haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+                targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) 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 (reportTargetProblems verbosity) return+                     $ resolveTargets+                         (selectPackageTargets haddockFlags)+                         selectComponentTarget+                         TargetProblemCommon+                         elaboratedPlan+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionHaddock+                                    targets+                                    elaboratedPlan+            return elaboratedPlan'++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++-- | 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 PackageId+                      -> [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?+    isRequested _ FLibKind   = fromFlag (haddockForeignLibs haddockFlags)+    isRequested _ ExeKind    = fromFlag (haddockExecutables haddockFlags)+    isRequested _ TestKind   = fromFlag (haddockTestSuites  haddockFlags)+    isRequested _ BenchKind  = fromFlag (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 :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget pkgid cname subtarget =+    either (Left . TargetProblemCommon) Right+  . selectComponentTargetBasic pkgid cname subtarget+++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @haddock@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon++     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   (TargetSelector PackageId)+  deriving (Eq, Show)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "build documentation for" problem++renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "build documentation for" targetSelector targets++renderTargetProblem(TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets "build documentation for" targetSelector
Distribution/Client/CmdRepl.hs view
@@ -1,32 +1,81 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-}  -- | cabal-install CLI command: repl -- module Distribution.Client.CmdRepl (+    -- * The @repl@ CLI and action+    replCommand,     replAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget   ) where  import Distribution.Client.ProjectOrchestration-         ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets-         , ProjectBuildContext(..), runProjectBuildPhase-         , printPlan, reportBuildFailures )-import Distribution.Client.ProjectConfig-         ( BuildTimeSettings(..) )-import Distribution.Client.ProjectPlanning-         ( PackageTarget(..) )-import Distribution.Client.BuildTarget-         ( readUserBuildTargets )+import Distribution.Client.CmdErrorMessages  import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup          ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Package+         ( packageName )+import Distribution.Types.ComponentName+         ( componentNameString )+import Distribution.Text+         ( display ) import Distribution.Verbosity-         ( normal )+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die', ordNub ) -import Control.Monad (unless)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad (when)  +replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+replCommand = Client.installCommand {+  commandName         = "new-repl",+  commandSynopsis     = "Open an interactive session for the given component.",+  commandUsage        = usageAlternatives "new-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 'new-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 ++ " new-repl\n"+     ++ "    for the default component in the package in the current directory\n"+     ++ "  " ++ pname ++ " new-repl pkgname\n"+     ++ "    for the default component in the package named 'pkgname'\n"+     ++ "  " ++ pname ++ " new-repl ./pkgfoo\n"+     ++ "    for the default component in the package in the ./pkgfoo directory\n"+     ++ "  " ++ pname ++ " new-repl cname\n"+     ++ "    for the component named 'cname'\n"+     ++ "  " ++ pname ++ " new-repl pkgname:cname\n"+     ++ "    for the component 'cname' in the package 'pkgname'\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }++ -- | 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.@@ -39,36 +88,205 @@ -- "Distribution.Client.ProjectOrchestration" -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> GlobalFlags -> IO ()-replAction (configFlags, configExFlags, installFlags, haddockFlags)+           -> [String] -> GlobalFlags -> IO ()+replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))            targetStrings globalFlags = do -    userTargets <- readUserBuildTargets targetStrings+    baseCtx <- establishProjectBaseContext verbosity cliConfig -    buildCtx@ProjectBuildContext{buildSettings} <--      runProjectPreBuildPhase-        verbosity-        ( globalFlags, configFlags, configExFlags-        , installFlags, haddockFlags )-        PreBuildHooks {-          hookPrePlanning      = \_ _ _ -> return (),-          hookSelectPlanSubset = selectReplTargets userTargets-        }+    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) targetStrings -    printPlan verbosity buildCtx+    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -    unless (buildSettingDryRun buildSettings) $ do-      plan <- runProjectBuildPhase-                verbosity-                buildCtx-      reportBuildFailures plan+            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'."++            -- 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+                         TargetProblemCommon+                         elaboratedPlan+                         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+                [TargetProblemMultipleTargets targets]++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionRepl+                                    targets+                                    elaboratedPlan+            return elaboratedPlan'++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes   where     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags -    -- When we interpret the targets on the command line, interpret them as-    -- repl targets (as opposed to say build or haddock targets).-    selectReplTargets =-      selectTargets-        ReplDefaultComponent-        ReplSpecificComponent+-- | 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 PackageId+                      -> [AvailableTarget k] -> Either TargetProblem [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 (TargetProblemMatchesMultiple 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 (TargetProblemMatchesMultiple 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 (TargetProblemMatchesMultiple 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 :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget pkgid cname subtarget =+    either (Left . TargetProblemCommon) Right+  . selectComponentTargetBasic pkgid cname subtarget+++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon++     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   (TargetSelector PackageId)++     -- | A single 'TargetSelector' matches multiple targets+   | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()]++     -- | Multiple 'TargetSelector's match multiple targets+   | TargetProblemMultipleTargets TargetsMap+  deriving (Eq, Show)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "open a repl for" problem++renderTargetProblem (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 (display pkgname) display (componentNameString cname)+          | t <- ts+          , let cname   = availableTargetComponentName t+                pkgname = packageName (availableTargetPackageId t)+          ]+      | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets+      ]+ ++ ".\n\n" ++ explanationSingleComponentLimitation+  where+    availableTargetComponentKind = componentKind+                                 . availableTargetComponentName++renderTargetProblem (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++renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "open a repl for" targetSelector targets++renderTargetProblem (TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets "open a repl for" targetSelector+++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 view
@@ -0,0 +1,289 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-}++-- | cabal-install CLI command: run+--+module Distribution.Client.CmdRun (+    -- * The @run@ CLI and action+    runCommand,+    runAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Types.ComponentName+         ( componentNameString )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die', ordNub )++import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad (when)+++runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+runCommand = Client.installCommand {+  commandName         = "new-run",+  commandSynopsis     = "Run an executable.",+  commandUsage        = usageAlternatives "new-run"+                          [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ],+  commandDescription  = Just $ \pname -> wrapText $+        "Runs the specified executable, first ensuring it is up to date.\n\n"++     ++ "Any executable in any package in the project can be specified. "+     ++ "A package can be specified if contains just one executable. "+     ++ "The default is to use the package in the current directory if it "+     ++ "contains just one executable.\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 ++ " new-run\n"+     ++ "    Run the executable in the package in the current directory\n"+     ++ "  " ++ pname ++ " new-run foo-tool\n"+     ++ "    Run the named executable (in any package in the project)\n"+     ++ "  " ++ pname ++ " new-run pkgfoo:foo-tool\n"+     ++ "    Run the executable 'foo-tool' in the package 'pkgfoo'\n"+     ++ "  " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n"+     ++ "    Build with '-O2' and run the program, passing it extra arguments.\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }+++-- | 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"+--+runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+          -> [String] -> GlobalFlags -> IO ()+runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+            targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) targetStrings++    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+                         TargetProblemCommon+                         elaboratedPlan+                         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+                [TargetProblemMultipleTargets targets]++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            return elaboratedPlan'++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++-- | 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 PackageId+                     -> [AvailableTarget k] -> Either TargetProblem [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 (TargetProblemMatchesMultiple 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 (TargetProblemNoExes targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    (targetsExesBuildable,+     targetsExesBuildable') = selectBuildableTargets'+                            . filterTargetsKind ExeKind+                            $ targets++    targetsExes             = forgetTargetsDetail+                            . filterTargetsKind ExeKind+                            $ targets+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @run@ command we just need to check it is a executable, in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem  k+selectComponentTarget pkgid cname subtarget@WholeComponent t+  | CExeName _ <- availableTargetComponentName t+  = either (Left . TargetProblemCommon) return $+           selectComponentTargetBasic pkgid cname subtarget t+  | otherwise+  = Left (TargetProblemComponentNotExe pkgid cname)++selectComponentTarget pkgid cname subtarget _+  = Left (TargetProblemIsSubComponent pkgid cname subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon+     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   (TargetSelector PackageId)++     -- | The 'TargetSelector' matches targets but no executables+   | TargetProblemNoExes      (TargetSelector PackageId)++     -- | A single 'TargetSelector' matches multiple targets+   | TargetProblemMatchesMultiple (TargetSelector PackageId) [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)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "run" problem++renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "run" targetSelector targets++renderTargetProblem (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."++renderTargetProblem (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+  where+    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter+    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter+    targetSelectorFilter (TargetComponent _ _ _)       = Nothing+++renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =+    "The run command is for running a single executable at once. The target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " which includes the executables "+ ++ renderListCommaAnd+      [ display name+      | cname@CExeName{} <- map availableTargetComponentName targets+      , let Just name = componentNameString cname+      ]+ ++ "."++renderTargetProblem (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."++renderTargetProblem (TargetProblemComponentNotExe pkgid cname) =+    "The run command is for running executables, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ display pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderTargetProblem (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+
+ Distribution/Client/CmdTest.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-}++-- | cabal-install CLI command: test+--+module Distribution.Client.CmdTest (+    -- * The @test@ CLI and action+    testCommand,+    testAction,++    -- * Internals exposed for testing+    TargetProblem(..),+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags+         , applyFlagDefaults )+import qualified Distribution.Client.Setup as Client+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++import Control.Monad (when)+++testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+testCommand = Client.installCommand {+  commandName         = "new-test",+  commandSynopsis     = "Run test-suites",+  commandUsage        = usageAlternatives "new-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.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " new-test\n"+     ++ "    Run all the test-suites in the package in the current directory\n"+     ++ "  " ++ pname ++ " new-test pkgname\n"+     ++ "    Run all the test-suites in the package named pkgname\n"+     ++ "  " ++ pname ++ " new-test cname\n"+     ++ "    Run the test-suite named cname\n"+     ++ "  " ++ pname ++ " new-test cname --enable-coverage\n"+     ++ "    Run the test-suite built with code coverage (including local libs used)\n\n"++     ++ cmdCommonHelpTextNewBuildBeta+   }+++-- | 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 :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+           -> [String] -> GlobalFlags -> IO ()+testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))+           targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) 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) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         TargetProblemCommon+                         elaboratedPlan+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionTest+                                    targets+                                    elaboratedPlan+            return elaboratedPlan'++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags configFlags configExFlags+                  installFlags haddockFlags++-- | 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 PackageId+                      -> [AvailableTarget k] -> Either TargetProblem [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 (TargetProblemNoTests 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 :: PackageId -> ComponentName -> SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget pkgid cname subtarget@WholeComponent t+  | CTestName _ <- availableTargetComponentName t+  = either (Left . TargetProblemCommon) return $+           selectComponentTargetBasic pkgid cname subtarget t+  | otherwise+  = Left (TargetProblemComponentNotTest pkgid cname)++selectComponentTarget pkgid cname subtarget _+  = Left (TargetProblemIsSubComponent pkgid cname subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @test@ command.+--+data TargetProblem =+     TargetProblemCommon       TargetProblemCommon++     -- | The 'TargetSelector' matches targets but none are buildable+   | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]++     -- | There are no targets at all+   | TargetProblemNoTargets   (TargetSelector PackageId)++     -- | The 'TargetSelector' matches targets but no test-suites+   | TargetProblemNoTests     (TargetSelector PackageId)++     -- | 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)++reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderTargetProblem++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (TargetProblemCommon problem) =+    renderTargetProblemCommon "run" problem++renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled "test" targetSelector targets++renderTargetProblem (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."++renderTargetProblem (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 ++ "."++      _ -> renderTargetProblemNoTargets "test" targetSelector+  where+    targetSelectorFilter (TargetPackage  _ _ mkfilter) = mkfilter+    targetSelectorFilter (TargetAllPackages  mkfilter) = mkfilter+    targetSelectorFilter (TargetComponent _ _ _)       = Nothing++renderTargetProblem (TargetProblemComponentNotTest pkgid cname) =+    "The test command is for running test suites, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ display pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderTargetProblem (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/Compat/FileLock.hsc view
@@ -0,0 +1,204 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum+-- required version. Though note that the locking functionality is not in+-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.+module Distribution.Client.Compat.FileLock (+    FileLockingNotSupported(..)+  , LockMode(..)+  , hLock+  , hTryLock+  ) where++#if MIN_VERSION_base(4,10,0)++import GHC.IO.Handle.Lock++#else++-- The remainder of this file is a modified copy+-- of GHC.IO.Handle.Lock from ghc-8.2.x+--+-- The modifications were just to the imports and the CPP, since we do not have+-- access to the HAVE_FLOCK from the ./configure script. We approximate the+-- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the+-- only known major Unix platform lacking flock().++import Control.Exception (Exception)+import Data.Typeable++#if defined(solaris2_HOST_OS)++import Control.Exception (throwIO)+import System.IO (Handle)++#else++import Data.Bits+import Data.Function+import Control.Concurrent.MVar++import Foreign.C.Error+import Foreign.C.Types++import GHC.IO.Handle.Types+import GHC.IO.FD+import GHC.IO.Exception++#if defined(mingw32_HOST_OS)++#if defined(i386_HOST_ARCH)+## define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH)+## define WINDOWS_CCONV ccall+#else+# error Unknown mingw32 arch+#endif++#include <windows.h>++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import GHC.Windows++#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */++#include <sys/file.h>++#endif /* !defined(mingw32_HOST_OS) */++#endif /* !defined(solaris2_HOST_OS) */++#endif /* MIN_VERSION_base */+++#if !(MIN_VERSION_base(4,10,0))++-- | Exception thrown by 'hLock' on non-Windows platforms that don't support+-- 'flock'.+data FileLockingNotSupported = FileLockingNotSupported+  deriving (Typeable, Show)++instance Exception FileLockingNotSupported++-- | Indicates a mode in which a file should be locked.+data LockMode = SharedLock | ExclusiveLock++-- | If a 'Handle' references a file descriptor, attempt to lock contents of the+-- underlying file in appropriate mode. If the file is already locked in+-- incompatible mode, this function blocks until the lock is established. The+-- lock is automatically released upon closing a 'Handle'.+--+-- Things to be aware of:+--+-- 1) This function may block inside a C call. If it does, in order to be able+-- to interrupt it with asynchronous exceptions and/or for other threads to+-- continue working, you MUST use threaded version of the runtime system.+--+-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,+-- hence all of their caveats also apply here.+--+-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this+-- function throws 'FileLockingNotImplemented'. We deliberately choose to not+-- provide fcntl based locking instead because of its broken semantics.+--+-- @since 4.10.0.0+hLock :: Handle -> LockMode -> IO ()+hLock h mode = lockImpl h "hLock" mode True >> return ()++-- | Non-blocking version of 'hLock'.+--+-- @since 4.10.0.0+hTryLock :: Handle -> LockMode -> IO Bool+hTryLock h mode = lockImpl h "hTryLock" mode False++----------------------------------------++#if defined(solaris2_HOST_OS)++-- | No-op implementation.+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl _ _ _ _ = throwIO FileLockingNotSupported++#else /* !defined(solaris2_HOST_OS) */++#if defined(mingw32_HOST_OS)++lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl h ctx mode block = do+  FD{fdFD = fd} <- handleToFd h+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do+    fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0+    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})+    -- We want to lock the whole file without looking up its size to be+    -- consistent with what flock does. According to documentation of LockFileEx+    -- "locking a region that goes beyond the current end-of-file position is+    -- not an error", however e.g. Windows 10 doesn't accept maximum possible+    -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by+    -- trying 2^32-1.+    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case+      True  -> return True+      False -> getLastError >>= \err -> if+        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False+        | err == #{const ERROR_OPERATION_ABORTED} -> retry+        | otherwise -> failWith ctx err+  where+    sizeof_OVERLAPPED = #{size OVERLAPPED}++    cmode = case mode of+      SharedLock    -> 0+      ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}++-- https://msdn.microsoft.com/en-us/library/aa297958.aspx+foreign import ccall unsafe "_get_osfhandle"+  c_get_osfhandle :: CInt -> IO HANDLE++-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx+foreign import WINDOWS_CCONV interruptible "LockFileEx"+  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL++#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */++lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool+lockImpl h ctx mode block = do+  FD{fdFD = fd} <- handleToFd h+  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})+  fix $ \retry -> c_flock fd flags >>= \case+    0 -> return True+    _ -> getErrno >>= \errno -> if+      | not block && errno == eWOULDBLOCK -> return False+      | errno == eINTR -> retry+      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing+  where+    cmode = case mode of+      SharedLock    -> #{const LOCK_SH}+      ExclusiveLock -> #{const LOCK_EX}++foreign import ccall interruptible "flock"+  c_flock :: CInt -> CInt -> IO CInt++#endif /* !defined(mingw32_HOST_OS) */++-- | Turn an existing Handle into a file descriptor. This function throws an+-- IOError if the Handle does not reference a file descriptor.+handleToFd :: Handle -> IO FD+handleToFd h = case h of+  FileHandle _ mv -> do+    Handle__{haDevice = dev} <- readMVar mv+    case cast dev of+      Just fd -> return fd+      Nothing -> throwErr "not a file descriptor"+  DuplexHandle{} -> throwErr "not a file handle"+  where+    throwErr msg = ioException $ IOError (Just h)+      InappropriateType "handleToFd" msg Nothing Nothing++#endif /* defined(solaris2_HOST_OS) */++#endif /* MIN_VERSION_base */
+ Distribution/Client/Compat/Prelude.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}++-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | This module does two things:+--+-- * Acts as a compatiblity 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+  , Prelude.IO+  , readMaybe+  ) where++import Prelude (IO)+import Distribution.Compat.Prelude.Internal hiding (IO)++#if MIN_VERSION_base(4,6,0)+import Text.Read+         ( readMaybe )+#endif++#if !MIN_VERSION_base(4,6,0)+-- | An implementation of readMaybe, for compatibility with older base versions.+readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+                [(x,"")] -> Just x+                _        -> Nothing+#endif
Distribution/Client/Compat/Process.hs view
@@ -24,7 +24,7 @@  import           Control.Exception (catch, throw) import           System.Exit       (ExitCode (ExitFailure))-import           System.IO.Error   (isDoesNotExistError)+import           System.IO.Error   (isDoesNotExistError, isPermissionError) import qualified System.Process    as P  -- | @readProcessWithExitCode@ creates an external process, reads its@@ -38,11 +38,12 @@ --   The version from @System.Process@ behaves inconsistently across --   platforms when an executable with the given name is not found: in --   some cases it returns an @ExitFailure@, in others it throws an---   exception.  This variant catches \"does not exist\" exceptions and---   turns them into @ExitFailure@s.+--   exception.  This variant catches \"does not exist\" and+--   \"permission denied\" exceptions and turns them into+--   @ExitFailure@s. readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) readProcessWithExitCode cmd args input =   P.readProcessWithExitCode cmd args input-    `catch` \e -> if isDoesNotExistError e+    `catch` \e -> if isDoesNotExistError e || isPermissionError e                     then return (ExitFailure 127, "", "")                     else throw e
− Distribution/Client/Compat/Time.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}-module Distribution.Client.Compat.Time-       ( ModTime(..) -- Needed for testing-       , getModTime, getFileAge, getCurTime-       , posixSecondsToModTime )-       where--import Control.Arrow    ( first )-import Data.Int         ( Int64 )-import Data.Word        ( Word64 )-import System.Directory ( getModificationTime )--import Distribution.Compat.Binary ( Binary )--import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )-#if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock.POSIX ( posixDayLength )-import Data.Time             ( diffUTCTime, getCurrentTime )-#else-import System.Time ( getClockTime, diffClockTimes-                   , normalizeTimeDiff, tdDay, tdHour )-#endif--#if defined mingw32_HOST_OS--import Data.Bits          ((.|.), unsafeShiftL)-#if MIN_VERSION_base(4,7,0)-import Data.Bits          (finiteBitSize)-#else-import Data.Bits          (bitSize)-#endif--import Data.Int           ( Int32 )-import Foreign            ( allocaBytes, peekByteOff )-import System.IO.Error    ( mkIOError, doesNotExistErrorType )-import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )--#else--import System.Posix.Files ( FileStatus, getFileStatus )--#if MIN_VERSION_unix(2,6,0)-import System.Posix.Files ( modificationTimeHiRes )-#else-import System.Posix.Files ( modificationTime )-#endif--#endif---- | An opaque type representing a file's modification time, represented--- internally as a 64-bit unsigned integer in the Windows UTC format.-newtype ModTime = ModTime Word64-                deriving (Binary, Bounded, Eq, Ord)--instance Show ModTime where-  show (ModTime x) = show x--instance Read ModTime where-  readsPrec p str = map (first ModTime) (readsPrec p str)---- | Return modification time of the given file. Works around the low clock--- resolution problem that 'getModificationTime' has on GHC < 7.8.------ This is a modified version of the code originally written for Shake by Neil--- Mitchell. See module Development.Shake.FileInfo.-getModTime :: FilePath -> IO ModTime--#if defined mingw32_HOST_OS---- Directly against the Win32 API.-getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do-  res <- getFileAttributesEx path info-  if not res-    then do-      let err = mkIOError doesNotExistErrorType-                "Distribution.Client.Compat.Time.getModTime"-                Nothing (Just path)-      ioError err-    else do-      dwLow  <- peekByteOff info-                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime-      dwHigh <- peekByteOff info-                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-#if MIN_VERSION_base(4,7,0)-      let qwTime =-            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)-            .|. (fromIntegral (dwLow :: DWORD))-#else-      let qwTime =-            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)-            .|. (fromIntegral (dwLow :: DWORD))-#endif-      return $! ModTime (qwTime :: Word64)--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV "windows.h GetFileAttributesExW"-  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL--getFileAttributesEx :: String -> LPVOID -> IO BOOL-getFileAttributesEx path lpFileInformation =-  withTString path $ \c_path ->-      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation--getFileExInfoStandard :: Int32-getFileExInfoStandard = 0--size_WIN32_FILE_ATTRIBUTE_DATA :: Int-size_WIN32_FILE_ATTRIBUTE_DATA = 36--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20--index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24--#else---- Directly against the unix library.-getModTime path = do-    st <- getFileStatus path-    return $! (extractFileTime st)--extractFileTime :: FileStatus -> ModTime-#if MIN_VERSION_unix(2,6,0)-extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)-#else-extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $-                    modificationTime x-#endif--#endif--windowsTick, secToUnixEpoch :: Word64-windowsTick    = 10000000-secToUnixEpoch = 11644473600---- | Convert POSIX seconds to ModTime.-posixSecondsToModTime :: Int64 -> ModTime-posixSecondsToModTime s =-  ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick---- | Convert 'POSIXTime' to 'ModTime'.-posixTimeToModTime :: POSIXTime -> ModTime-posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision-                       + (secToUnixEpoch * windowsTick)---- | Return age of given file in days.-getFileAge :: FilePath -> IO Double-getFileAge file = do-  t0 <- getModificationTime file-#if MIN_VERSION_directory(1,2,0)-  t1 <- getCurrentTime-  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength-#else-  t1 <- getClockTime-  let dt = normalizeTimeDiff (t1 `diffClockTimes` t0)-  return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0-#endif---- | Return the current time as 'ModTime'.-getCurTime :: IO ModTime-getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
− Distribution/Client/ComponentDeps.hs 
@@ -1,161 +0,0 @@--- | Fine-grained package dependencies------ Like many others, this module is meant to be "double-imported":------ > import Distribution.Client.ComponentDeps (--- >     Component--- >   , ComponentDep--- >   , ComponentDeps--- >   )--- > import qualified Distribution.Client.ComponentDeps as CD-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.ComponentDeps (-    -- * Fine-grained package dependencies-    Component(..)-  , ComponentDep-  , ComponentDeps -- opaque-    -- ** Constructing ComponentDeps-  , empty-  , fromList-  , singleton-  , insert-  , filterDeps-  , fromLibraryDeps-  , fromSetupDeps-  , fromInstalled-    -- ** Deconstructing ComponentDeps-  , toList-  , flatDeps-  , nonSetupDeps-  , libraryDeps-  , setupDeps-  , select-  ) where--import Data.Map (Map)-import qualified Data.Map as Map-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup (Semigroup((<>)))-import GHC.Generics-import Data.Foldable (fold)--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable(foldMap))-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif--{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}---- | Component of a package.-data Component =-    ComponentLib-  | ComponentExe   String-  | ComponentTest  String-  | ComponentBench String-  | ComponentSetup-  deriving (Show, Eq, Ord, Generic)--instance Binary Component---- | 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)--{--------------------------------------------------------------------------------  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'---- | 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.-libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (== ComponentLib)---- | 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/Client/Config.hs view
@@ -48,8 +48,6 @@          ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand, defaultGlobalFlags          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -64,10 +62,10 @@          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , AllowNewer(..)+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , installDirsOptions, optionDistPref-         , programConfigurationPaths', programConfigurationOptions+         , programDbPaths', programDbOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs          ( InstallDirs(..), defaultInstallDirs@@ -86,19 +84,21 @@ import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) ) import qualified Distribution.Text as Text-         ( Text(..) )+         ( Text(..), display ) import Distribution.Simple.Command          ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)          , viewAsFieldDescr ) import Distribution.Simple.Program-         ( defaultProgramConfiguration )+         ( defaultProgramDb ) import Distribution.Simple.Utils-         ( die, notice, warn, lowercase, cabalVersion )+         ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity          ( Verbosity, normal ) +import Distribution.Solver.Types.ConstraintSource+ import Data.List          ( partition, find, foldl' ) import Data.Maybe@@ -227,7 +227,8 @@         globalRequireSandbox    = combine globalRequireSandbox,         globalIgnoreSandbox     = combine globalIgnoreSandbox,         globalIgnoreExpiry      = combine globalIgnoreExpiry,-        globalHttpTransport     = combine globalHttpTransport+        globalHttpTransport     = combine globalHttpTransport,+        globalNix               = combine globalNix         }         where           combine        = combine'        savedGlobalFlags@@ -239,37 +240,45 @@         installDryRun                = combine installDryRun,         installMaxBackjumps          = combine installMaxBackjumps,         installReorderGoals          = combine installReorderGoals,+        installCountConflicts        = combine installCountConflicts,         installIndependentGoals      = combine installIndependentGoals,         installShadowPkgs            = combine installShadowPkgs,         installStrongFlags           = combine installStrongFlags,+        installAllowBootLibInstalls  = combine installAllowBootLibInstalls,         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+        installOfflineMode           = combine installOfflineMode,+        installProjectFileName       = combine installProjectFileName         }         where           combine        = combine'        savedInstallFlags           lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags        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,@@ -298,8 +307,11 @@         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@@ -321,6 +333,8 @@         configExactConfiguration  = combine configExactConfiguration,         configFlagError           = combine configFlagError,         configRelocatable         = combine configRelocatable,+        configAllowOlder          = combineMonoid savedConfigureFlags+                                    configAllowOlder,         configAllowNewer          = combineMonoid savedConfigureFlags                                     configAllowNewer         }@@ -350,7 +364,7 @@                                        `mappend` savedGlobalInstallDirs b        combinedSavedUploadFlags = UploadFlags {-        uploadCheck       = combine uploadCheck,+        uploadCandidate   = combine uploadCandidate,         uploadDoc         = combine uploadDoc,         uploadUsername    = combine uploadUsername,         uploadPassword    = combine uploadPassword,@@ -380,6 +394,7 @@         haddockExecutables   = combine haddockExecutables,         haddockTestSuites    = combine haddockTestSuites,         haddockBenchmarks    = combine haddockBenchmarks,+        haddockForeignLibs   = combine haddockForeignLibs,         haddockInternal      = combine haddockInternal,         haddockCss           = combine haddockCss,         haddockHscolour      = combine haddockHscolour,@@ -525,13 +540,9 @@                   remoteRepoKeyThreshold = 0                 } | secure /= Just False             = r {-              --TODO: When we want to switch us from using opt-in to opt-out-              -- security for the central hackage server, uncomment the-              -- following line. That will cause the default (of unspecified)-              -- to get interpreted as if it were "secure: True". For the-              -- moment it means the keys get added but you have to manually-              -- set "secure: True" to opt-in.-              --remoteRepoSecure       = Just True,+                -- Use hackage-security by default unless you opt-out with+                -- secure: False+                remoteRepoSecure       = Just True,                 remoteRepoRootKeys     = defaultHackageRemoteRepoKeys,                 remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold               }@@ -605,7 +616,7 @@       return conf     Just (ParseFailed err) -> do       let (line, msg) = locatedErrorMsg err-      die $+      die' verbosity $           "Error parsing config file " ++ configFile         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -664,15 +675,17 @@   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."-      ,""-      ,"-- Cabal library version: " ++ showVersion cabalVersion+      ,"--"+      ,"-- This config file was generated using the following versions"+      ,"-- of Cabal and cabal-install:"+      ,"-- Cabal library version: " ++ Text.display cabalVersion       ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version       ,"",""       ]@@ -686,21 +699,38 @@ commentSavedConfig = do   userInstallDirs   <- defaultInstallDirs defaultCompiler True True   globalInstallDirs <- defaultInstallDirs defaultCompiler False True-  return SavedConfig {-    savedGlobalFlags       = defaultGlobalFlags,-    savedInstallFlags      = defaultInstallFlags,-    savedConfigureExFlags  = defaultConfigExFlags,-    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {-      configUserInstall    = toFlag defaultUserInstall,-      configAllowNewer     = Just AllowNewerNone-    },-    savedUserInstallDirs   = fmap toFlag userInstallDirs,-    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,-    savedUploadFlags       = commandDefaultFlags uploadCommand,-    savedReportFlags       = commandDefaultFlags reportCommand,-    savedHaddockFlags      = defaultHaddockFlags-  }+  let conf0 = mempty {+        savedGlobalFlags       = defaultGlobalFlags {+            globalRemoteRepos = toNubList [defaultRemoteRepo]+            },+        savedInstallFlags      = defaultInstallFlags,+        savedConfigureExFlags  = defaultConfigExFlags,+        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {+            configUserInstall    = toFlag defaultUserInstall,+            configAllowNewer     = Just (AllowNewer RelaxDepsNone),+            configAllowOlder     = Just (AllowOlder RelaxDepsNone)+            },+        savedUserInstallDirs   = fmap toFlag userInstallDirs,+        savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+        savedUploadFlags       = commandDefaultFlags uploadCommand,+        savedReportFlags       = commandDefaultFlags reportCommand,+        savedHaddockFlags      = defaultHaddockFlags +        }+  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]@@ -721,17 +751,15 @@        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })-       ,let showAllowNewer Nothing               = mempty-            showAllowNewer (Just AllowNewerNone) = Disp.text "False"-            showAllowNewer (Just _)              = Disp.text "True"--            toAllowNewer True  = Just AllowNewerAll-            toAllowNewer False = Just AllowNewerNone--            pkgs = (Just . AllowNewerSome) `fmap` parseOptCommaList Text.parse-            parseAllowNewer = (toAllowNewer `fmap` Text.parse) Parse.<++ pkgs in+       ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in+        simpleField "allow-older"+        (showRelaxDeps . fmap unAllowOlder) parseAllowOlder+        configAllowOlder (\v flags -> flags { configAllowOlder = v })+       ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse+            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in         simpleField "allow-newer"-        showAllowNewer parseAllowNewer+        (showRelaxDeps . fmap unAllowNewer) parseAllowNewer         configAllowNewer (\v flags -> flags { configAllowNewer = v })         -- TODO: The following is a temporary fix. The "optimization"         -- and "debug-info" fields are OptArg, and viewAsFieldDescr@@ -797,7 +825,7 @@    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)-       ["verbose", "check", "documentation"] []+       ["verbose", "check", "documentation", "publish"] []    ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)@@ -831,6 +859,15 @@       , name `notElem` exclusions ]     optional = Parse.option mempty . fmap toFlag ++    showRelaxDeps Nothing              = mempty+    showRelaxDeps (Just RelaxDepsNone) = Disp.text "False"+    showRelaxDeps (Just _)             = Disp.text "True"++    toRelaxDeps True  = RelaxDepsAll+    toRelaxDeps False = RelaxDepsNone++ -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig]@@ -1004,8 +1041,8 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos-           . savedGlobalFlags $ vals of+      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 ""@@ -1025,6 +1062,7 @@   $+$ configFlagsSection "program-default-options" withProgramOptionsFields                          configProgramArgs   where+    getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags     mcomment = Just comment     installDirsSection name field =       ppSection "install-dirs" name installDirsFields@@ -1042,11 +1080,9 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions -ppRemoteRepoSection :: RemoteRepo -> Doc-ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals)-        remoteRepoFields def vals-  where-    def = Just (emptyRemoteRepo "ignored") { remoteRepoSecure = Just False }+ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc+ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)+        remoteRepoFields (Just def) vals  remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields =@@ -1094,14 +1130,14 @@ withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields =   map viewAsFieldDescr $-  programConfigurationPaths' (++ "-location") defaultProgramConfiguration+  programDbPaths' (++ "-location") defaultProgramDb                              ParseArgs id (++)  -- | Fields for the 'program-default-options' section. withProgramOptionsFields :: [FieldDescr [(String, [String])]] withProgramOptionsFields =   map viewAsFieldDescr $-  programConfigurationOptions defaultProgramConfiguration ParseArgs id (++)+  programDbOptions defaultProgramDb ParseArgs id (++)  -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist.
Distribution/Client/Configure.hs view
@@ -15,70 +15,82 @@     configure,     configureSetupScript,     chooseCabalVersion,-    checkConfigExFlags+    checkConfigExFlags,+    -- * Saved configure flags+    readConfigFlagsFrom, readConfigFlags,+    cabalConfigFlagsFile,+    writeConfigFlagsTo, writeConfigFlags,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..)-         , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName )-import Distribution.Client.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Client.Setup-         ( ConfigExFlags(..), configureCommand, filterConfigureFlags-         , RepoContext(..) )+         ( 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 qualified Distribution.Client.ComponentDeps as CD import Distribution.Package (PackageId) 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 (ProgramConfiguration )+import Distribution.Simple.Program (ProgramDb)+import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup-         ( ConfigFlags(..), AllowNewer(..)+         ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, lookupPackageName ) import Distribution.Simple.Utils          ( defaultPackageDesc )-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( Package(..), UnitId, packageName-         , Dependency(..), thisPackageVersion-         )+         ( Package(..), packageName )+import Distribution.Types.Dependency+         ( Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+#else import Distribution.PackageDescription.Parse-         ( readPackageDescription )+         ( readGenericPackageDescription )+#endif import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Version-         ( anyVersion, thisVersion )+         ( Version, mkVersion, anyVersion, thisVersion+         , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils-         ( warn, notice, debug, die )+         ( warn, notice, debug, die' ) import Distribution.Simple.Setup-         ( isAllowNewer )+         ( isRelaxDeps ) import Distribution.System          ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity          ( Verbosity )-import Distribution.Version-         ( Version(..), VersionRange, orLaterVersion ) -import Control.Monad (unless)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-import Data.Maybe (isJust, fromMaybe)+import System.FilePath ( (</>) )  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.@@ -88,11 +100,13 @@   where     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed     -- for '--allow-newer' to work.-    allowNewer = isAllowNewer-                 (fromMaybe AllowNewerNone $ configAllowNewer configFlags)+    allowNewer = isRelaxDeps+                 (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags)+    allowOlder = isRelaxDeps+                 (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags) -    defaultVersionRange = if allowNewer-                          then orLaterVersion (Version [1,19,2] [])+    defaultVersionRange = if allowOlder || allowNewer+                          then orLaterVersion (mkVersion [1,19,2])                           else anyVersion  -- | Configure the package found in the local directory@@ -101,17 +115,17 @@           -> RepoContext           -> Compiler           -> Platform-          -> ProgramConfiguration+          -> ProgramDb           -> ConfigFlags           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repoCtxt comp platform conf+configure verbosity packageDBs repoCtxt comp platform progdb   configFlags configExFlags extraArgs = do -  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb   sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-  pkgConfigDb       <- readPkgConfigDb      verbosity conf+  pkgConfigDb       <- readPkgConfigDb      verbosity progdb    checkConfigExFlags verbosity installedPkgIndex                      (packageIndex sourcePkgDb) configExFlags@@ -131,17 +145,18 @@       setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)         Nothing configureCommand (const configFlags) extraArgs -    Right installPlan -> case InstallPlan.ready installPlan of+    Right installPlan0 ->+     let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0+     in case fst (InstallPlan.ready installPlan) of       [pkg@(ReadyPackage-             (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)-                                 _ _ _)-             _)] -> do+              (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)+                                 _ _ _))] -> do         configurePackage verbosity           platform (compilerInfo comp)           (setupScriptOptions installedPkgIndex (Just pkg))           configFlags pkg extraArgs -      _ -> die $ "internal error: configure install plan should have exactly "+      _ -> die' verbosity $ "internal error: configure install plan should have exactly "               ++ "one local ready package."    where@@ -153,7 +168,7 @@         packageDBs         comp         platform-        conf+        progdb         (fromFlagOrDefault            (useDistPref defaultSetupScriptOptions)            (configDistPref configFlags))@@ -168,7 +183,7 @@ configureSetupScript :: PackageDBStack                      -> Compiler                      -> Platform-                     -> ProgramConfiguration+                     -> ProgramDb                      -> FilePath                      -> VersionRange                      -> Maybe Lock@@ -179,7 +194,7 @@ configureSetupScript packageDBs                      comp                      platform-                     conf+                     progdb                      distPref                      cabalVersion                      lock@@ -193,10 +208,11 @@     , usePlatform              = Just platform     , usePackageDB             = packageDBs'     , usePackageIndex          = index'-    , useProgramConfig         = conf+    , useProgramDb             = progdb     , useDistPref              = distPref     , useLoggingHandle         = Nothing     , useWorkingDir            = Nothing+    , useExtraPathEnv          = []     , setupCacheLock           = lock     , useWin32CleanHack        = False     , forceExternalSetupMethod = forceExternal@@ -209,6 +225,7 @@     , 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@@ -228,8 +245,8 @@      maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo     maybeSetupBuildInfo = do-      ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) _-                 <- mpkg+      ReadyPackage cpkg <- mpkg+      let gpkg = packageDescription (confPkgSource cpkg)       PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)      -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If@@ -238,16 +255,14 @@     defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends                        maybeSetupBuildInfo -    explicitSetupDeps :: Maybe [(UnitId, PackageId)]+    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 _ deps <- mpkg-      return [ ( Installed.installedUnitId deppkg-               , Installed.sourcePackageId    deppkg-               )-             | deppkg <- CD.setupDeps deps+      ReadyPackage cpkg <- mpkg+      return [ ( cid, srcid )+             | ConfiguredId srcid (Just PkgDesc.CLibName) cid <- CD.setupDeps (confPkgDeps cpkg)              ]  -- | Warn if any constraints or preferences name packages that are not in the@@ -284,17 +299,20 @@                  -> InstalledPackageIndex                  -> SourcePackageDb                  -> PkgConfigDb-                 -> IO (Progress String String InstallPlan)+                 -> IO (Progress String String SolverInstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags   installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do-  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity+  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 {         packageInfoId             = packageId pkg,-        Source.packageDescription = pkg,+        packageDescription        = pkg,         packageSource             = LocalUnpackedPackage ".",         packageDescrOverride      = Nothing       }@@ -304,8 +322,10 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =-          removeUpperBounds-          (fromMaybe AllowNewerNone $ configAllowNewer configFlags)+          removeLowerBounds+          (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags)+        . removeUpperBounds+          (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags)          . addPreferences             -- preferences from the config file or command line@@ -321,22 +341,34 @@          . addConstraints             -- package flags from the config file or command line-            [ let pc = PackageConstraintFlags (packageName pkg)-                       (configConfigurationsFlags configFlags)+            [ 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 = PackageConstraintStanzas (packageName pkg) $+            [ 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] @@ -359,34 +391,78 @@                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-                 (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)-                                                  flags stanzas _)-                               deps)+                 (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))                  extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs    where+    gpkg = packageDescription spkg     configureFlags   = filterConfigureFlags configFlags {+      configIPID = if isJust (flagToMaybe (configIPID configFlags))+                    -- Make sure cabal configure --ipid works.+                    then configIPID configFlags+                    else toFlag (display 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  = [ thisPackageVersion (packageId deppkg)-                           | deppkg <- CD.nonSetupDeps deps ],-      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                              Installed.installedUnitId deppkg)-                           | deppkg <- CD.nonSetupDeps deps ],+      configConstraints  = [ thisPackageVersion srcid+                           | ConfiguredId srcid (Just PkgDesc.CLibName) _uid <- CD.nonSetupDeps deps ],+      configDependencies = [ (packageName srcid, uid)+                           | ConfiguredId srcid (Just PkgDesc.CLibName) uid <- CD.nonSetupDeps deps ],       -- Use '--exact-configuration' if supported.       configExactConfiguration = toFlag True,       configVerbosity          = toFlag verbosity,-      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),+      -- 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 finalizePackageDescription flags+    pkg = case finalizePD flags (enableStanzas stanzas)            (const True)-           platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ReadyPackage failed"+           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 view
@@ -23,13 +23,14 @@     resolveWithoutDependencies,      -- * Constructing resolver policies-    DepResolverParams(..),+    PackageProperty(..),     PackageConstraint(..),+    scopeToplevel,     PackagesPreferenceDefault(..),     PackagePreference(..),-    InstalledPreference(..),      -- ** Standard policy+    basicInstallPolicy,     standardInstallPolicy,     PackageSpecifier(..), @@ -37,8 +38,6 @@     applySandboxInstallPolicy,      -- ** Extra policy options-    dontUpgradeNonUpgradeablePackages,-    hideBrokenInstalledPackages,     upgradeDependencies,     reinstallTargets, @@ -47,60 +46,52 @@     addPreferences,     setPreferenceDefault,     setReorderGoals,+    setCountConflicts,     setIndependentGoals,     setAvoidReinstalls,     setShadowPkgs,     setStrongFlags,+    setAllowBootLibInstalls,     setMaxBackjumps,-    addSourcePackages,-    hideInstalledPackagesSpecificByUnitId,-    hideInstalledPackagesSpecificBySourcePackageId,-    hideInstalledPackagesAllVersions,+    setEnableBackjumping,+    setSolveExecutables,+    setGoalOrder,+    setSolverVerbosity,+    removeLowerBounds,     removeUpperBounds,     addDefaultSetupDependencies,+    addSetupCabalMinVersionConstraint,   ) where -import Distribution.Client.Dependency.TopDown-         ( topDownResolver )-import Distribution.Client.Dependency.Modular+import Distribution.Solver.Modular          ( modularResolver, SolverConfig(..) )-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.PkgConfigDb (PkgConfigDb)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types-         ( SourcePackageDb(SourcePackageDb), SourcePackage(..)-         , ConfiguredPackage(..), ConfiguredId(..)-         , OptionalStanza(..), enableStanzas )+         ( SourcePackageDb(SourcePackageDb)+         , UnresolvedPkgLoc, UnresolvedSourcePackage ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)-         , PackageConstraint(..), showPackageConstraint-         , LabeledPackageConstraint(..), unlabelPackageConstraint-         , ConstraintSource(..), showConstraintSource-         , PackagePreferences(..), InstalledPreference(..)-         , PackagesPreferenceDefault(..)-         , Progress(..), foldProgress )+         ( PreSolver(..), Solver(..)+         , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) ) import Distribution.Client.Targets-import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId-         , Package(..), packageName, packageVersion-         , UnitId, Dependency(Dependency))+         ( 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-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Client.PackageUtils          ( externalBuildDepends ) import Distribution.Version-         ( VersionRange, Version(..), anyVersion, orLaterVersion, thisVersion-         , withinRange, simplifyVersionRange )+         ( Version, mkVersion+         , VersionRange, anyVersion, thisVersion, orLaterVersion, withinRange+         , simplifyVersionRange, removeLowerBound, removeUpperBound ) import Distribution.Compiler          ( CompilerInfo(..) ) import Distribution.System@@ -108,20 +99,41 @@ import Distribution.Client.Utils          ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils-         ( comparing, warn, info )+         ( comparing ) import Distribution.Simple.Configure          ( relaxPackageDeps ) import Distribution.Simple.Setup-         ( AllowNewer(..) )+         ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Text          ( display ) import Distribution.Verbosity-         ( Verbosity )+         ( normal, Verbosity )+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          ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on)-import Data.Maybe  (fromMaybe)+import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)@@ -138,37 +150,54 @@ -- implemented in terms of adjustments to the parameters. -- data DepResolverParams = DepResolverParams {-       depResolverTargets           :: [PackageName],+       depResolverTargets           :: Set PackageName,        depResolverConstraints       :: [LabeledPackageConstraint],        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,        depResolverInstalledPkgIndex :: InstalledPackageIndex,-       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex SourcePackage,-       depResolverReorderGoals      :: Bool,-       depResolverIndependentGoals  :: Bool,-       depResolverAvoidReinstalls   :: Bool,-       depResolverShadowPkgs        :: Bool,-       depResolverStrongFlags       :: Bool,-       depResolverMaxBackjumps      :: Maybe Int+       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,+       depResolverReorderGoals      :: ReorderGoals,+       depResolverCountConflicts    :: CountConflicts,+       depResolverIndependentGoals  :: IndependentGoals,+       depResolverAvoidReinstalls   :: AvoidReinstalls,+       depResolverShadowPkgs        :: ShadowPkgs,+       depResolverStrongFlags       :: StrongFlags,++       -- | Whether to allow base and its dependencies to be installed.+       depResolverAllowBootLibInstalls :: AllowBootLibInstalls,++       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 display (depResolverTargets p))+     "targets: " ++ intercalate ", " (map display $ Set.toList (depResolverTargets p))   ++ "\nconstraints: "   ++   concatMap (("\n  " ++) . showLabeledConstraint)        (depResolverConstraints p)   ++ "\npreferences: "   ++   concatMap (("\n  " ++) . showPackagePreference)        (depResolverPreferences p)-  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault p)-  ++ "\nreorder goals: "     ++ show (depResolverReorderGoals      p)-  ++ "\nindependent goals: " ++ show (depResolverIndependentGoals  p)-  ++ "\navoid reinstalls: "  ++ show (depResolverAvoidReinstalls   p)-  ++ "\nshadow packages: "   ++ show (depResolverShadowPkgs        p)-  ++ "\nstrong flags: "      ++ show (depResolverStrongFlags       p)+  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault        p)+  ++ "\nreorder goals: "     ++ show (asBool (depResolverReorderGoals     p))+  ++ "\ncount conflicts: "   ++ show (asBool (depResolverCountConflicts   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))   ++ "\nmax backjumps: "     ++ maybe "infinite" show-                                     (depResolverMaxBackjumps      p)+                                     (depResolverMaxBackjumps             p)   where     showLabeledConstraint :: LabeledPackageConstraint -> String     showLabeledConstraint (LabeledPackageConstraint pc src) =@@ -205,29 +234,35 @@   display pn ++ " " ++ show st  basicDepResolverParams :: InstalledPackageIndex-                       -> PackageIndex.PackageIndex SourcePackage+                       -> PackageIndex.PackageIndex UnresolvedSourcePackage                        -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex =     DepResolverParams {-       depResolverTargets           = [],+       depResolverTargets           = Set.empty,        depResolverConstraints       = [],        depResolverPreferences       = [],        depResolverPreferenceDefault = PreferLatestForSelected,        depResolverInstalledPkgIndex = installedPkgIndex,        depResolverSourcePkgIndex    = sourcePkgIndex,-       depResolverReorderGoals      = False,-       depResolverIndependentGoals  = False,-       depResolverAvoidReinstalls   = False,-       depResolverShadowPkgs        = False,-       depResolverStrongFlags       = False,-       depResolverMaxBackjumps      = Nothing+       depResolverReorderGoals      = ReorderGoals False,+       depResolverCountConflicts    = CountConflicts True,+       depResolverIndependentGoals  = IndependentGoals False,+       depResolverAvoidReinstalls   = AvoidReinstalls False,+       depResolverShadowPkgs        = ShadowPkgs False,+       depResolverStrongFlags       = StrongFlags False,+       depResolverAllowBootLibInstalls = AllowBootLibInstalls False,+       depResolverMaxBackjumps      = Nothing,+       depResolverEnableBackjumping = EnableBackjumping True,+       depResolverSolveExecutables  = SolveExecutables True,+       depResolverGoalOrder         = Nothing,+       depResolverVerbosity         = normal      }  addTargets :: [PackageName]            -> DepResolverParams -> DepResolverParams addTargets extraTargets params =     params {-      depResolverTargets = extraTargets ++ depResolverTargets params+      depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params     }  addConstraints :: [LabeledPackageConstraint]@@ -253,42 +288,80 @@       depResolverPreferenceDefault = preferenceDefault     } -setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams-setReorderGoals b params =+setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams+setReorderGoals reorder params =     params {-      depResolverReorderGoals = b+      depResolverReorderGoals = reorder     } -setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams-setIndependentGoals b params =+setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams+setCountConflicts count params =     params {-      depResolverIndependentGoals = b+      depResolverCountConflicts = count     } -setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams-setAvoidReinstalls b params =+setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams+setIndependentGoals indep params =     params {-      depResolverAvoidReinstalls = b+      depResolverIndependentGoals = indep     } -setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams-setShadowPkgs b params =+setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams+setAvoidReinstalls avoid params =     params {-      depResolverShadowPkgs = b+      depResolverAvoidReinstalls = avoid     } -setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams-setStrongFlags b params =+setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams+setShadowPkgs shadow params =     params {-      depResolverStrongFlags = b+      depResolverShadowPkgs = shadow     } +setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams+setStrongFlags sf params =+    params {+      depResolverStrongFlags = sf+    }++setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams+setAllowBootLibInstalls i params =+    params {+      depResolverAllowBootLibInstalls = 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@@ -297,20 +370,24 @@   where     extraConstraints =       [ LabeledPackageConstraint-        (PackageConstraintInstalled pkgname)+        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)         ConstraintSourceNonUpgradeablePackage-      | notElem (PackageName "base") (depResolverTargets params)-      , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"-                                   , "integer-simple" ]+      | 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-prim"+                   , mkPackageName "integer-gmp"+                   , mkPackageName "integer-simple"+                   , mkPackageName "template-haskell"+                   ]       , isInstalled pkgname ]-    -- TODO: the top down resolver chokes on the base constraints-    -- below when there are no targets and thus no dep on base.-    -- Need to refactor constraints separate from needing packages.+     isInstalled = not . null                 . InstalledPackageIndex.lookupPackageName                                  (depResolverInstalledPkgIndex params) -addSourcePackages :: [SourcePackage]+addSourcePackages :: [UnresolvedSourcePackage]                   -> DepResolverParams -> DepResolverParams addSourcePackages pkgs params =     params {@@ -319,17 +396,6 @@               (depResolverSourcePkgIndex params) pkgs     } -hideInstalledPackagesSpecificByUnitId :: [UnitId]-                                                     -> DepResolverParams-                                                     -> DepResolverParams-hideInstalledPackagesSpecificByUnitId pkgids params =-    --TODO: this should work using exclude constraints instead-    params {-      depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deleteUnitId)-               (depResolverInstalledPkgIndex params) pkgids-    }- hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]                                                   -> DepResolverParams                                                   -> DepResolverParams@@ -352,17 +418,6 @@     }  -hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams-hideBrokenInstalledPackages params =-    hideInstalledPackagesSpecificByUnitId pkgids params-  where-    pkgids = map Installed.installedUnitId-           . InstalledPackageIndex.reverseDependencyClosure-                            (depResolverInstalledPkgIndex params)-           . map (Installed.installedUnitId . fst)-           . InstalledPackageIndex.brokenPackages-           $ depResolverInstalledPkgIndex params- -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none). --@@ -371,27 +426,43 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds AllowNewerNone params = params-removeUpperBounds allowNewer     params =+removeUpperBounds (AllowNewer RelaxDepsNone) params = params+removeUpperBounds (AllowNewer allowNewer)    params =     params {       depResolverSourcePkgIndex = sourcePkgIndex'     }   where     sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params -    relaxDeps :: SourcePackage -> SourcePackage+    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage     relaxDeps srcPkg = srcPkg {-      packageDescription = relaxPackageDeps allowNewer+      packageDescription = relaxPackageDeps removeUpperBound allowNewer                            (packageDescription srcPkg)       } +-- | Dual of 'removeUpperBounds'+removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams+removeLowerBounds (AllowOlder RelaxDepsNone) params = params+removeLowerBounds (AllowOlder allowNewer)    params =+    params {+      depResolverSourcePkgIndex = sourcePkgIndex'+    }+  where+    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params++    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    relaxDeps srcPkg = srcPkg {+      packageDescription = relaxPackageDeps removeLowerBound allowNewer+                           (packageDescription srcPkg)+      }+ -- | 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 :: (SourcePackage -> Maybe [Dependency])+addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])                             -> DepResolverParams -> DepResolverParams addDefaultSetupDependencies defaultSetupDeps params =     params {@@ -399,7 +470,7 @@         fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)     }   where-    applyDefaultSetupDeps :: SourcePackage -> SourcePackage+    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage     applyDefaultSetupDeps srcpkg =         srcpkg {           packageDescription = gpkgdesc {@@ -420,21 +491,38 @@         gpkgdesc = packageDescription 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" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest   reinstallTargets :: DepResolverParams -> DepResolverParams reinstallTargets params =-    hideInstalledPackagesAllVersions (depResolverTargets params) params+    hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params  -standardInstallPolicy :: InstalledPackageIndex-                      -> SourcePackageDb-                      -> [PackageSpecifier SourcePackage]-                      -> DepResolverParams-standardInstallPolicy+-- | A basic solver policy on which all others are built.+--+basicInstallPolicy :: InstalledPackageIndex+                   -> SourcePackageDb+                   -> [PackageSpecifier UnresolvedSourcePackage]+                   -> DepResolverParams+basicInstallPolicy     installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)     pkgSpecifiers @@ -451,20 +539,35 @@   . hideInstalledPackagesSpecificBySourcePackageId       [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] -  . addDefaultSetupDependencies mkDefaultSetupDeps-   . addSourcePackages       [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]    $ basicDepResolverParams       installedPkgIndex sourcePkgIndex ++-- | The policy used by all the standard commands, install, fetch, freeze etc+-- (but not the new-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 :: SourcePackage -> Maybe [Dependency]+      mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]       mkDefaultSetupDeps srcpkg | affected        =-        Just [Dependency (PackageName "Cabal")-              (orLaterVersion $ Version [1,24] [])]+        Just [Dependency (mkPackageName "Cabal")+              (orLaterVersion $ mkVersion [1,24])]                                 | otherwise       = Nothing         where           gpkgdesc = packageDescription srcpkg@@ -503,8 +606,9 @@         (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]    . addConstraints-      [ let pc = PackageConstraintVersion (packageName pkg)-                 (thisVersion (packageVersion pkg))+      [ let pc = PackageConstraint+                 (scopeToplevel $ packageName pkg)+                 (PackagePropertyVersion $ thisVersion (packageVersion pkg))         in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep       | pkg <- modifiedDeps ] @@ -531,19 +635,12 @@ -- ------------------------------------------------------------  chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver-chooseSolver verbosity preSolver _cinfo =+chooseSolver _verbosity preSolver _cinfo =     case preSolver of-      AlwaysTopDown -> do-        warn verbosity "Topdown solver is deprecated"-        return TopDown       AlwaysModular -> do         return Modular-      Choose -> do-        info verbosity "Choosing modular solver."-        return Modular -runSolver :: Solver -> SolverConfig -> DependencyResolver-runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options+runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc runSolver Modular = modularResolver  -- | Run the dependency solver.@@ -557,11 +654,11 @@                     -> PkgConfigDb                     -> Solver                     -> DepResolverParams-                    -> Progress String String InstallPlan+                    -> Progress String String SolverInstallPlan      --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _pkgConfigDB _solver params-  | null (depResolverTargets params)+  | Set.null (depResolverTargets params)   = return (validateSolverResult platform comp indGoals [])   where     indGoals = depResolverIndependentGoals params@@ -570,8 +667,10 @@      Step (showDepResolverParams finalparams)   $ fmap (validateSolverResult platform comp indGoals)-  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls-                      shadowing strFlags maxBkjumps)+  $ runSolver solver (SolverConfig reordGoals cntConflicts+                      indGoals noReinstalls+                      shadowing strFlags allowBootLibs maxBkjumps enableBj+                      solveExes order verbosity)                      platform comp installedPkgIndex sourcePkgIndex                      pkgConfigDB preferences constraints targets   where@@ -581,23 +680,23 @@       prefs defpref       installedPkgIndex       sourcePkgIndex-      reorderGoals+      reordGoals+      cntConflicts       indGoals       noReinstalls       shadowing       strFlags-      maxBkjumps)     = dontUpgradeNonUpgradeablePackages-                      -- TODO:-                      -- The modular solver can properly deal with broken-                      -- packages and won't select them. So the-                      -- 'hideBrokenInstalledPackages' function should be moved-                      -- into a module that is specific to the top-down solver.-                      . (if solver /= Modular then hideBrokenInstalledPackages-                                              else id)-                      $ params+      allowBootLibs+      maxBkjumps+      enableBj+      solveExes+      order+      verbosity) =+        if asBool (depResolverAllowBootLibInstalls params)+        then params+        else dontUpgradeNonUpgradeablePackages params -    preferences = interpretPackagesPreference-                    (Set.fromList targets) defpref prefs+    preferences = interpretPackagesPreference targets defpref prefs   -- | Give an interpretation to the global 'PackagesPreference' as@@ -648,24 +747,21 @@ -- validateSolverResult :: Platform                      -> CompilerInfo-                     -> Bool-                     -> [ResolverPackage]-                     -> InstallPlan+                     -> IndependentGoals+                     -> [ResolverPackage UnresolvedPkgLoc]+                     -> SolverInstallPlan validateSolverResult platform comp indepGoals pkgs =     case planPackagesProblems platform comp pkgs of-      [] -> case InstallPlan.new indepGoals index of+      [] -> case SolverInstallPlan.new indepGoals graph of               Right plan     -> plan               Left  problems -> error (formatPlanProblems problems)       problems               -> error (formatPkgProblems problems)    where-    index = InstalledPackageIndex.fromList (map toPlanPackage pkgs)--    toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg-    toPlanPackage (Configured  pkg) = InstallPlan.Configured  pkg+    graph = Graph.fromDistinctList pkgs      formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem-    formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem+    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem      formatProblemMessage problems =       unlines $@@ -673,11 +769,13 @@       : "The proposed (invalid) plan contained the following problems:"       : problems       ++ "Proposed plan:"-      : [InstallPlan.showPlanIndex index]+      : [SolverInstallPlan.showPlanIndex pkgs]   data PlanPackageProblem =-       InvalidConfiguredPackage ConfiguredPackage [PackageProblem]+       InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)+                                [PackageProblem]+     | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]  showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =@@ -685,15 +783,20 @@   ++ " has an invalid configuration, in particular:\n"   ++ unlines [ "  " ++ showPackageProblem problem              | problem <- packageProblems ]+showPlanPackageProblem (DuplicatePackageSolverId pid dups) =+     "Package " ++ display (packageId pid) ++ " has "+  ++ show (length dups) ++ " duplicate instances."  planPackagesProblems :: Platform -> CompilerInfo-                     -> [ResolverPackage]+                     -> [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 (head dups)) dups+     | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]  data PackageProblem = DuplicateFlag PD.FlagName                     | MissingFlag   PD.FlagName@@ -704,14 +807,14 @@                     | InvalidDep    Dependency PackageId  showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (PD.FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag+showPackageProblem (DuplicateFlag flag) =+  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag -showPackageProblem (MissingFlag (PD.FlagName flag)) =-  "missing an assignment for the flag: " ++ flag+showPackageProblem (MissingFlag flag) =+  "missing an assignment for the flag: " ++ PD.unFlagName flag -showPackageProblem (ExtraFlag (PD.FlagName flag)) =-  "extra flag given that is not used by the package: " ++ 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: "@@ -736,9 +839,9 @@ -- dependencies are satisfied by the specified packages. -- configuredPackageProblems :: Platform -> CompilerInfo-                          -> ConfiguredPackage -> [PackageProblem]+                          -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo-  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =+  (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') =      [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]   ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]@@ -749,9 +852,10 @@   ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]   ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps                             , not (packageSatisfiesDependency pkgid dep) ]+  -- TODO: sanity tests on executable deps   where     specifiedDeps :: ComponentDeps [PackageId]-    specifiedDeps = fmap (map confSrcId) specifiedDeps'+    specifiedDeps = fmap (map solverSrcId) specifiedDeps'      mergedFlags = mergeBy compare       (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))@@ -785,12 +889,13 @@     -- of the `nubOn` in `mergeDeps`.     requiredDeps :: [Dependency]     requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags+      --TODO: use something lower level than finalizePD+      case finalizePD specifiedFlags+         (enableStanzas stanzas)          (const True)          platform cinfo          []-         (enableStanzas stanzas $ packageDescription pkg) of+         (packageDescription pkg) of         Right (resolvedPkg, _) ->              externalBuildDepends resolvedPkg           ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)@@ -817,14 +922,15 @@ -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams-                           -> Either [ResolveNoDepsError] [SourcePackage]+                           -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex-                              _reorderGoals _indGoals _avoidReinstalls-                              _shadowing _strFlags _maxBjumps) =-    collectEithers (map selectPackage targets)+                              _reorderGoals _countConflicts _indGoals _avoidReinstalls+                              _shadowing _strFlags _maxBjumps _enableBj+                              _solveExes _allowBootLibInstalls _order _verbosity) =+    collectEithers $ map selectPackage (Set.toList targets)   where-    selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage+    selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage     selectPackage pkgname       | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions       | otherwise    = Right $! maximumBy bestByPrefs choices@@ -856,12 +962,12 @@       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap     packageVersionConstraintMap =       let pcs = map unlabelPackageConstraint constraints-      in Map.fromList [ (name, range)-                      | PackageConstraintVersion name range <- pcs ]+      in Map.fromList [ (scopeToPackageName scope, range)+                      | PackageConstraint+                          scope (PackagePropertyVersion range) <- pcs ]      packagePreferences :: PackageName -> PackagePreferences-    packagePreferences = interpretPackagesPreference-                           (Set.fromList targets) defpref prefs+    packagePreferences = interpretPackagesPreference targets defpref prefs   collectEithers :: [Either a b] -> Either [a] [b]
− Distribution/Client/Dependency/Modular.hs 
@@ -1,59 +0,0 @@-module Distribution.Client.Dependency.Modular-         ( modularResolver, SolverConfig(..)) 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 Data.Map as M-         ( fromListWith )-import Distribution.Client.Dependency.Modular.Assignment-         ( Assignment, toCPs )-import Distribution.Client.Dependency.Modular.Dependency-         ( RevDepMap )-import Distribution.Client.Dependency.Modular.ConfiguredConversion-         ( convCP )-import Distribution.Client.Dependency.Modular.IndexConversion-         ( convPIs )-import Distribution.Client.Dependency.Modular.Log-         ( logToProgress )-import Distribution.Client.Dependency.Modular.Package-         ( PN )-import Distribution.Client.Dependency.Modular.Solver-         ( SolverConfig(..), solve )-import Distribution.Client.Dependency.Types-         ( DependencyResolver, ResolverPackage-         , PackageConstraint(..), unlabelPackageConstraint )-import Distribution.System-         ( Platform(..) )---- | Ties the two worlds together: classic cabal-install vs. the modular--- solver. Performs the necessary translations before and after.-modularResolver :: SolverConfig -> DependencyResolver-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess)      $ -- convert install plan-  logToProgress (maxBackjumps sc) $ -- convert log format into progress format-  solve sc cinfo idx pkgConfigDB pprefs gcs pns-    where-      -- Indices have to be converted into solver-specific uniform index.-      idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx-      -- Constraints have to be converted into a finite map indexed by PN.-      gcs    = M.fromListWith (++) (map pair pcs)-        where-          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])--      -- Results have to be converted into an install plan.-      postprocess :: Assignment -> RevDepMap -> [ResolverPackage]-      postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)--      -- Helper function to extract the PN from a constraint.-      pcName :: PackageConstraint -> PN-      pcName (PackageConstraintVersion   pn _) = pn-      pcName (PackageConstraintInstalled pn  ) = pn-      pcName (PackageConstraintSource    pn  ) = pn-      pcName (PackageConstraintFlags     pn _) = pn-      pcName (PackageConstraintStanzas   pn _) = pn
− Distribution/Client/Dependency/Modular/Assignment.hs 
@@ -1,150 +0,0 @@-module Distribution.Client.Dependency.Modular.Assignment-    ( Assignment(..)-    , FAssignment-    , SAssignment-    , PreAssignment(..)-    , extend-    , toCPs-    ) where--import Control.Applicative-import Control.Monad-import Data.Array as A-import Data.List as L-import Data.Map as M-import Data.Maybe-import Prelude hiding (pi)--import Language.Haskell.Extension (Extension, Language)--import Distribution.PackageDescription (FlagAssignment) -- from Cabal-import Distribution.Client.Types (OptionalStanza)-import Distribution.Client.Utils.LabeledGraph-import Distribution.Client.ComponentDeps (ComponentDeps, Component)-import qualified Distribution.Client.ComponentDeps as CD--import Distribution.Client.Dependency.Modular.Configured-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Version---- | A (partial) package assignment. Qualified package names--- are associated with instances.-type PAssignment    = Map QPN I---- | A (partial) package preassignment. Qualified package names--- are associated with constrained instances. Constrained instances--- record constraints about the instances that can still be chosen,--- and in the extreme case fix a concrete instance.-type PPreAssignment = Map QPN (CI QPN)-type FAssignment    = Map QFN Bool-type SAssignment    = Map QSN Bool---- | A (partial) assignment of variables.-data Assignment = A PAssignment FAssignment SAssignment-  deriving (Show, Eq)---- | A preassignment comprises knowledge about variables, but not--- necessarily fixed values.-data PreAssignment = PA PPreAssignment FAssignment SAssignment---- | 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-       -> (PN -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable-       -> Var QPN-       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-extend extSupported langSupported pkgPresent var = foldM extendSingle-  where--    extendSingle :: PPreAssignment -> Dep QPN-                 -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-    extendSingle a (Ext  ext )  =-      if extSupported  ext  then Right a-                            else Left (varToConflictSet var, [Ext ext])-    extendSingle a (Lang lang)  =-      if langSupported lang then Right a-                            else Left (varToConflictSet var, [Lang lang])-    extendSingle a (Pkg pn vr)  =-      if pkgPresent pn vr then Right a-                          else Left (varToConflictSet var, [Pkg pn vr])-    extendSingle a (Dep qpn ci) =-      let ci' = M.findWithDefault (Constrained []) qpn a-      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of-            Left (c, (d, d')) -> Left  (c, L.map (Dep qpn) (simplify (P qpn) d d'))-            Right x           -> Right x--    -- We're trying to remove trivial elements of the conflict. If we're just-    -- making a choice pkg == instance, and pkg => pkg == instance is a part-    -- of the conflict, then this info is clear from the context and does not-    -- have to be repeated.-    simplify v (Fixed _ var') c | v == var && var' == var = [c]-    simplify v c (Fixed _ var') | v == var && var' == var = [c]-    simplify _ c              d                           = [c, d]---- | 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 (++) $-           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $-           M.toList $-           fa-    -- Stanzas per package.-    sapp :: Map QPN [OptionalStanza]-    sapp = M.fromListWith (++) $-           L.map (\ ((SN (PI 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)-                   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 [] qpn fapp)-                                 (M.findWithDefault [] qpn sapp)-                                 (depp' qpn))-          ps
− Distribution/Client/Dependency/Modular/Builder.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Builder (buildTree) 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 Data.List as L-import Data.Map as M-import Prelude hiding (sequence, mapM)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ (PSQ)-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree--import Distribution.Client.ComponentDeps (Component)---- | The state needed during the build phase of the search tree.-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  :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)-  next  :: BuildType,            -- ^ kind of node to generate next-  qualifyOptions :: QualifyOptions -- ^ qualification options-}---- | 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 -> [OpenGoal Component] -> BuildState -> BuildState-extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs-  where-    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState-    go g o []                                               = s { rdeps = g, open = o }-    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs-      -- Note: for 'Flagged' goals, we always insert, so later additions win.-      -- This is important, because in general, if a goal is inserted twice,-      -- the later addition will have better dependency information.-    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs-    go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs)-      | qpn == qpn'       = go                            g               o  ngs-          -- we ignore self-dependencies at this point; TODO: more care may be needed-      | qpn `M.member` g  = go (M.adjust ((c, qpn'):) qpn g)              o  ngs-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs-          -- code above is correct; insert/adjust have different arg order-    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs-    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs--    cons' = P.cons . forgetCompOpenGoal---- | 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 -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->-                    BuildState -> BuildState-scopedExtendOpen qpn i gr 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 (PI qpn i) fn) b [] []) $ M.toList fdefs-    -- Combine new package and flag goals-    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)-    -- NOTE:-    ---    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially-    -- multiple times, both via the flag declaration and via dependencies.-    -- The order is potentially important, because the occurrences via-    -- dependencies may record flag-dependency information. After a number-    -- of bugs involving computing this information incorrectly, however,-    -- we're currently not using carefully computed inter-flag dependencies-    -- anymore, but instead use 'simplifyVar' when computing conflict sets-    -- to map all flags of one package to a single flag for conflict set-    -- purposes, thereby treating them all as interdependent.-    ---    -- If we ever move to a more clever algorithm again, then the line above-    -- needs to be looked at very carefully, and probably be replaced by-    -- more systematically computed flag dependency information.---- | Datatype that encodes what to build next-data BuildType =-    Goals                                  -- ^ build a goal choice node-  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal-  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance-  deriving Show--build :: BuildState -> Tree QGoalReason-build = ana go-  where-    go :: 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.-    go bs@(BS { rdeps = rds, open = gs, next = Goals })-      | P.null gs = DoneF rds-      | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })-                                              (P.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.-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal"-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal"-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =-      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal"-    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =-      -- If the package does not exist in the index, we construct an emty PChoiceF node for it-      -- After all, we have no choices here. Alternatively, we could immediately construct-      -- a Fail node here, but that would complicate the construction of conflict sets.-      -- We will probably want to give this case special treatment when generating error-      -- messages though.-      case M.lookup pn idx of-        Nothing  -> PChoiceF qpn gr (P.fromList [])-        Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->-                                                           (POption i Nothing, bs { next = Instance qpn i info gr }))-                                                         (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.-    ---    -- TODO: Should we include the flag default in the tree?-    go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =-      FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]))-      where-        reorder True  = id-        reorder False = reverse-        trivial = L.null t && L.null f--    -- 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).--    go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =-      SChoiceF qsn gr trivial (P.fromList-        [(False,                                                             bs  { next = Goals }),-         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])-      where-        trivial = 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.-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =-      go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)-             { next = Goals })---- | 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 -> Bool -> [PN] -> Tree QGoalReason-buildTree idx ind igs =-    build BS {-        index = idx-      , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)-      , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)-      , next  = Goals-      , qualifyOptions = defaultQualifyOptions idx-      }-  where-    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal--    qpns | ind       = makeIndependent igs-         | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
− Distribution/Client/Dependency/Modular/Configured.hs 
@@ -1,13 +0,0 @@-module Distribution.Client.Dependency.Modular.Configured-    ( CP(..)-    ) where--import Distribution.PackageDescription (FlagAssignment) -- from Cabal-import Distribution.Client.Types (OptionalStanza)-import Distribution.Client.ComponentDeps (ComponentDeps)--import Distribution.Client.Dependency.Modular.Package---- | 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/Client/Dependency/Modular/ConfiguredConversion.hs 
@@ -1,54 +0,0 @@-module Distribution.Client.Dependency.Modular.ConfiguredConversion-    ( convCP-    ) where--import Data.Maybe-import Prelude hiding (pi)--import Distribution.Package (UnitId)--import Distribution.Client.Types-import Distribution.Client.Dependency.Types (ResolverPackage(..))-import qualified Distribution.Client.PackageIndex as CI-import qualified Distribution.Simple.PackageIndex as SI--import Distribution.Client.Dependency.Modular.Configured-import Distribution.Client.Dependency.Modular.Package--import Distribution.Client.ComponentDeps (ComponentDeps)---- | 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 ->-          CP QPN -> ResolverPackage-convCP iidx sidx (CP qpi fa es ds) =-  case convPI qpi of-    Left  pi -> PreExisting-                  (fromJust $ SI.lookupUnitId iidx pi)-    Right pi -> Configured $ ConfiguredPackage-                  srcpkg-                  fa-                  es-                  ds'-      where-        Just srcpkg = CI.lookupPackageId sidx pi-  where-    ds' :: ComponentDeps [ConfiguredId]-    ds' = fmap (map convConfId) ds--convPI :: PI QPN -> Either UnitId PackageId-convPI (PI _ (I _ (Inst pi))) = Left pi-convPI qpi                    = Right $ confSrcId $ convConfId qpi--convConfId :: PI QPN -> ConfiguredId-convConfId (PI (Q _ pn) (I v loc)) = ConfiguredId {-      confSrcId  = sourceId-    , confInstId = installedId-    }-  where-    sourceId    = PackageIdentifier pn v-    installedId = case loc of-                    Inst pi    -> pi-                    _otherwise -> fakeUnitId sourceId
− Distribution/Client/Dependency/Modular/ConflictSet.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE CPP #-}--- | Conflict sets------ Intended for double import------ > import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet)--- > import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS-module Distribution.Client.Dependency.Modular.ConflictSet (-    ConflictSet -- opaque-  , showCS-    -- Set-like operations-  , toList-  , union-  , unions-  , insert-  , empty-  , singleton-  , member-  , filter-  , fromList-  ) where--import Prelude hiding (filter)-import Data.List (intercalate)-import Data.Set (Set)-import qualified Data.Set as S--import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Var---- | The set of variables involved in a solver conflict------ Since these variables should be preprocessed in some way, this type is--- kept abstract.-newtype ConflictSet qpn = CS { fromConflictSet :: Set (Var qpn) }-  deriving (Eq, Ord, Show)--showCS :: ConflictSet QPN -> String-showCS = intercalate ", " . map showVar . toList--{--------------------------------------------------------------------------------  Set-like operations--------------------------------------------------------------------------------}--toList :: ConflictSet qpn -> [Var qpn]-toList = S.toList . fromConflictSet--union :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn-union (CS a) (CS b) = CS (a `S.union` b)--unions :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn-unions = CS . S.unions . map fromConflictSet--insert :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn-insert var (CS set) = CS (S.insert (simplifyVar var) set)--empty :: ConflictSet qpn-empty = CS S.empty--singleton :: Var qpn -> ConflictSet qpn-singleton = CS . S.singleton . simplifyVar--member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool-member var (CS set) = S.member (simplifyVar var) set--#if MIN_VERSION_containers(0,5,0)-filter :: (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn-#else-filter :: Ord qpn => (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn-#endif-filter p (CS set) = CS $ S.filter p set--fromList :: Ord qpn => [Var qpn] -> ConflictSet qpn-fromList = CS . S.fromList . map simplifyVar
− Distribution/Client/Dependency/Modular/Cycles.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Cycles (-    detectCyclesPhase-  ) where--import Prelude hiding (cycle)-import Data.Graph (SCC)-import qualified Data.Graph as Gr-import qualified Data.Map   as Map--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS---- | Find and reject any solutions that are cyclic-detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason-detectCyclesPhase = cata go-  where-    -- The only node of interest is DoneF-    go :: TreeF QGoalReason (Tree QGoalReason) -> Tree QGoalReason-    go (PChoiceF qpn gr     cs) = PChoice qpn gr     cs-    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs-    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   cs-    go (GoalChoiceF         cs) = GoalChoice         cs-    go (FailF cs reason)        = Fail cs reason--    -- We check for cycles only if we have actually found a solution-    -- This minimizes the number of cycle checks we do as cycles are rare-    go (DoneF revDeps) = do-      case findCycles revDeps of-        Nothing     -> Done revDeps-        Just relSet -> Fail relSet CyclicDependencies---- | Given the reverse dependency map from a 'Done' node in the tree, as well--- as the full conflict set containing all decisions that led to that 'Done'--- node, check if the solution is cyclic. If it is, return the conflict set--- containing all decisions that could potentially break the cycle.-findCycles :: RevDepMap -> Maybe (ConflictSet QPN)-findCycles revDeps =-    case cycles of-      []  -> Nothing-      c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c-  where-    cycles :: [[QPN]]-    cycles = [vs | Gr.CyclicSCC vs <- scc]--    scc :: [SCC QPN]-    scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps--    aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])-    aux (fr, to) = (fr, fr, map snd to)
− Distribution/Client/Dependency/Modular/Dependency.hs 
@@ -1,400 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.Dependency.Modular.Dependency (-    -- * Variables-    Var(..)-  , simplifyVar-  , varPI-    -- * Conflict sets-  , ConflictSet-  , CS.showCS-    -- * Constrained instances-  , CI(..)-  , merge-    -- * Flagged dependencies-  , FlaggedDeps-  , FlaggedDep(..)-  , Dep(..)-  , showDep-  , flattenFlaggedDeps-  , QualifyOptions(..)-  , qualifyDeps-  , unqualifyDeps-    -- ** Setting/forgetting components-  , forgetCompOpenGoal-  , setCompFlaggedDeps-    -- * Reverse dependency map-  , RevDepMap-    -- * Goals-  , Goal(..)-  , GoalReason(..)-  , QGoalReason-  , ResetVar(..)-  , goalVarToConflictSet-  , varToConflictSet-  , goalReasonToVars-    -- * Open goals-  , OpenGoal(..)-  , close-  ) where--import Prelude hiding (pi)--import Data.Map (Map)-import qualified Data.List as L--import Language.Haskell.Extension (Extension(..), Language(..))--import Distribution.Text--import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet)-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Var-import Distribution.Client.Dependency.Modular.Version-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS--import Distribution.Client.ComponentDeps (Component(..))--{--------------------------------------------------------------------------------  Constrained instances--------------------------------------------------------------------------------}---- | Constrained instance. If the choice has already been made, this is--- a fixed instance, and we record the package name for which the choice--- is for convenience. Otherwise, it is a list of version ranges paired with--- the goals / variables that introduced them.-data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]-  deriving (Eq, Show, Functor)--showCI :: CI QPN -> String-showCI (Fixed i _)      = "==" ++ showI i-showCI (Constrained vr) = showVR (collapse vr)---- | 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.------ 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 :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)-merge c@(Fixed i g1)       d@(Fixed j g2)-  | i == j                                    = Right c-  | otherwise                                 = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))-merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...-  where-    go []              = Right c-    go (d@(vr, g2) : vrs)-      | checkVR vr v   = go vrs-      | otherwise      = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d]))-merge c@(Constrained _)    d@(Fixed _ _)      = merge d c-merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))--{--------------------------------------------------------------------------------  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.------ However, top-level goals are also modelled as dependencies, but of course--- these don't actually belong in any component of any package. Therefore, we--- parameterize 'FlaggedDeps' and derived datatypes with a type argument that--- specifies whether or not we have a component: we only ever instantiate this--- type argument with @()@ for top-level goals, or 'Component' for everything--- else (we could express this as a kind at the type-level, but that would--- require a very recent GHC).------ Note however, crucially, that independent of the type parameters, the list--- of dependencies underneath a flag choice or stanza choices _always_ uses--- Component as the type argument. This is important: when we pick a value for--- a flag, we _must_ know what component the new dependencies belong to, or--- else we don't be able to construct fine-grained reverse dependencies.-type FlaggedDeps comp qpn = [FlaggedDep comp qpn]---- | Flagged dependencies can either be plain dependency constraints,--- or flag-dependent dependency trees.-data FlaggedDep comp qpn =-    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)-  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-  | Simple (Dep qpn) comp-  deriving (Eq, Show)---- | Conversatively flatten out flagged dependencies------ NOTE: We do not filter out duplicates.-flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]-flattenFlaggedDeps = concatMap aux-  where-    aux :: FlaggedDep Component qpn -> [(Dep 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 Component qpn-type FalseFlaggedDeps qpn = FlaggedDeps Component qpn---- | A dependency (constraint) associates a package name with a--- constrained instance.------ 'Dep' 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 'Dep' ought to have two type variables.)-data Dep qpn = Dep  qpn (CI qpn)  -- dependency on a package-             | Ext  Extension     -- dependency on a language extension-             | Lang Language      -- dependency on a language version-             | Pkg  PN VR         -- dependency on a pkg-config package-  deriving (Eq, Show)--showDep :: Dep QPN -> String-showDep (Dep qpn (Fixed i v)            ) =-  (if P qpn /= v then showVar v ++ " => " else "") ++-  showQPN qpn ++ "==" ++ showI i-showDep (Dep qpn (Constrained [(vr, v)])) =-  showVar v ++ " => " ++ showQPN qpn ++ showVR vr-showDep (Dep qpn ci                     ) =-  showQPN qpn ++ showCI ci-showDep (Ext ext)   = "requires " ++ display ext-showDep (Lang lang) = "requires " ++ display lang-showDep (Pkg pn vr) = "requires pkg-config package "-                      ++ display pn ++ display vr-                      ++ ", not found in the pkg-config database"---- | 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 Component PN -> FlaggedDeps Component QPN-qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go-  where-    go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN-    go = map go1--    go1 :: FlaggedDep Component PN -> FlaggedDep Component 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 (goD dep comp) comp--    -- Suppose package B has a setup dependency on package A.-    -- This will be recorded as something like-    ---    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])-    ---    -- 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 goal or the goal reason chain.-    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 ci) comp-      | qBase  dep  = Dep (Q (PP ns (Base  pn)) dep) (fmap (Q pp) ci)-      | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci)-      | otherwise   = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) 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-                   Setup _     -> q-                   Unqualified -> q-                   Base _      -> Unqualified--    -- 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' packaeg 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 comp QPN -> FlaggedDeps comp PN-unqualifyDeps = go-  where-    go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN-    go = map go1--    go1 :: FlaggedDep comp QPN -> FlaggedDep comp 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 (goD dep) comp--    goD :: Dep QPN -> Dep PN-    goD (Dep qpn ci) = Dep (unq qpn) (fmap unq ci)-    goD (Ext  ext)   = Ext ext-    goD (Lang lang)  = Lang lang-    goD (Pkg pn vr)  = Pkg pn vr--    unq :: QPN -> PN-    unq (Q _ pn) = pn--{--------------------------------------------------------------------------------  Setting/forgetting the Component--------------------------------------------------------------------------------}--forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()-forgetCompOpenGoal = mapCompOpenGoal $ const ()--setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn-setCompFlaggedDeps = mapCompFlaggedDeps . const--{--------------------------------------------------------------------------------  Auxiliary: Mapping over the Component goal--  We don't export these, because the only type instantiations for 'a' and 'b'-  here should be () or Component. (We could express this at the type level-  if we relied on newer versions of GHC.)--------------------------------------------------------------------------------}--mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b-mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr--mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn-mapCompFlaggedDeps = L.map . mapCompFlaggedDep--mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn-mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f-mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t-mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)--{--------------------------------------------------------------------------------  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-  | PDependency (PI qpn)-  | FDependency (FN qpn) Bool-  | SDependency (SN qpn)-  deriving (Eq, Show, Functor)--type QGoalReason = GoalReason QPN--class ResetVar f where-  resetVar :: Var qpn -> f qpn -> f qpn--instance ResetVar CI where-  resetVar v (Fixed i _)       = Fixed i v-  resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs)--instance ResetVar Dep where-  resetVar v (Dep qpn ci) = Dep qpn (resetVar v ci)-  resetVar _ (Ext ext)    = Ext ext-  resetVar _ (Lang lang)  = Lang lang-  resetVar _ (Pkg pn vr)  = Pkg pn vr--instance ResetVar Var where-  resetVar = const---- | Compute a singleton conflict set from a goal, containing just--- the goal variable.------ NOTE: This is just a call to 'varToConflictSet' under the hood;--- the 'GoalReason' is ignored.-goalVarToConflictSet :: Goal qpn -> ConflictSet qpn-goalVarToConflictSet (Goal g _gr) = varToConflictSet g---- | Compute a singleton conflict set from a 'Var'-varToConflictSet :: Var qpn -> ConflictSet qpn-varToConflictSet = CS.singleton---- | A goal reason is mostly just a variable paired with the--- decision we made for that variable (except for user goals,--- where we cannot really point to a solver variable). This--- function drops the decision and recovers the list of--- variables (which will be empty or contain one element).----goalReasonToVars :: GoalReason qpn -> [Var qpn]-goalReasonToVars UserGoal                 = []-goalReasonToVars (PDependency (PI qpn _)) = [P qpn]-goalReasonToVars (FDependency qfn _)      = [F qfn]-goalReasonToVars (SDependency qsn)        = [S qsn]--{--------------------------------------------------------------------------------  Open goals--------------------------------------------------------------------------------}---- | For open goals as they occur during the build phase, we need to store--- additional information about flags.-data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason-  deriving (Eq, Show)---- | Closes a goal, i.e., removes all the extraneous information that we--- need only during the build phase.-close :: OpenGoal comp -> Goal QPN-close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr-close (OpenGoal (Simple (Ext     _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal"-close (OpenGoal (Simple (Lang    _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal"-close (OpenGoal (Simple (Pkg   _ _) _) _ ) =-  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Pkg goal"-close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr-close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr--{--------------------------------------------------------------------------------  Version ranges paired with origins--------------------------------------------------------------------------------}--type VROrigin qpn = (VR, Var qpn)---- | Helper function to collapse a list of version ranges with origins into--- a single, simplified, version range.-collapse :: [VROrigin qpn] -> VR-collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR
− Distribution/Client/Dependency/Modular/Explore.hs 
@@ -1,123 +0,0 @@-module Distribution.Client.Dependency.Modular.Explore-    ( backjump-    , backjumpAndExplore-    ) where--import Data.Foldable as F-import Data.Map as M--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Log-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS-import Distribution.Client.Dependency.Modular.Tree-import qualified Distribution.Client.Dependency.Types as T---- | This function takes the variable we're currently considering, an--- initial 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 initial 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'.----backjump :: F.Foldable t => Var QPN -> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a-backjump var initial xs = F.foldr combine logBackjump xs initial-  where-    combine :: ConflictSetLog a-            -> (ConflictSet QPN -> ConflictSetLog a)-            ->  ConflictSet QPN -> ConflictSetLog a-    combine (T.Done x)    _ _               = T.Done x-    combine (T.Fail cs)   f csAcc-      | not (var `CS.member` cs) = logBackjump cs-      | otherwise                = f (csAcc `CS.union` cs)-    combine (T.Step m ms) f cs   = T.Step m (combine ms f cs)--    logBackjump :: ConflictSet QPN -> ConflictSetLog a-    logBackjump cs = failWith (Failure cs Backjump) cs--type ConflictSetLog = T.Progress Message (ConflictSet QPN)---- | A tree traversal that simultaneously propagates conflict sets up--- the tree from the leaves and creates a log.-exploreLog :: Tree QGoalReason -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))-exploreLog = cata go-  where-    go :: TreeF QGoalReason (Assignment -> ConflictSetLog (Assignment, RevDepMap))-                         -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))-    go (FailF c fr)          _           = failWith (Failure c fr) c-    go (DoneF rdm)           a           = succeedWith Success (a, rdm)-    go (PChoiceF qpn gr     ts) (A pa fa sa)   =-      backjump (P qpn) (avoidSet (P qpn) gr) $    -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...-                    r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice-      ts-    go (FChoiceF qfn gr _ _ ts) (A pa fa sa)   =-      backjump (F qfn) (avoidSet (F qfn) gr) $    -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryF qfn k) $          -- log and ...-                    r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice-      ts-    go (SChoiceF qsn gr _   ts) (A pa fa sa)   =-      backjump (S qsn) (avoidSet (S qsn) gr) $    -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryS qsn k) $          -- log and ...-                    r (A pa fa (M.insert qsn k sa))) -- record the pkg choice-      ts-    go (GoalChoiceF        ts) a           =-      P.casePSQ ts-        (failWith (Failure CS.empty EmptyGoalChoice) CS.empty) -- empty goal choice is an internal error-        (\ k v _xs -> continueWith (Next (close k)) (v a))     -- commit to the first goal choice---- | 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 actual 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 initial 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 initial conflict set becomes the--- actual conflict set.------ - In a situation where we backjump past the current node, the goal reason--- of the current node will be added to the conflict set.----avoidSet :: Var QPN -> QGoalReason -> ConflictSet QPN-avoidSet var gr =-  CS.fromList (var : goalReasonToVars gr)---- | Interface.-backjumpAndExplore :: Tree QGoalReason -> Log Message (Assignment, RevDepMap)-backjumpAndExplore t = toLog $ exploreLog t (A M.empty M.empty M.empty)-  where-    toLog :: T.Progress step fail done -> Log step done-    toLog = T.foldProgress T.Step (const (T.Fail ())) T.Done
− Distribution/Client/Dependency/Modular/Flag.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Flag-    ( FInfo(..)-    , Flag-    , FlagInfo-    , FN(..)-    , QFN-    , QSN-    , SN(..)-    , mkFlag-    , showFBool-    , showQFN-    , showQFNBool-    , showQSN-    , showQSNBool-    ) where--import Data.Map as M-import Prelude hiding (pi)--import Distribution.PackageDescription hiding (Flag) -- from Cabal--import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Types (OptionalStanza(..))---- | Flag name. Consists of a package instance and the flag identifier itself.-data FN qpn = FN (PI qpn) Flag-  deriving (Eq, Ord, Show, Functor)---- | Flag identifier. Just a string.-type Flag = FlagName--unFlag :: Flag -> String-unFlag (FlagName fn) = fn--mkFlag :: String -> Flag-mkFlag fn = FlagName fn---- | Flag info. Default value, whether the flag is manual, and--- whether the flag is weak. Manual flags can only be set explicitly.--- Weak flags are typically deferred by the solver.-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool }-  deriving (Eq, Ord, 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 (PI qpn) OptionalStanza-  deriving (Eq, Ord, Show, Functor)---- | Qualified stanza name.-type QSN = SN QPN--unStanza :: OptionalStanza -> String-unStanza TestStanzas  = "test"-unStanza BenchStanzas = "bench"--showQFNBool :: QFN -> Bool -> String-showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b--showQSNBool :: QSN -> Bool -> String-showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b--showFBool :: FN qpn -> Bool -> String-showFBool (FN _ f) True  = "+" ++ unFlag f-showFBool (FN _ f) False = "-" ++ unFlag f--showSBool :: SN qpn -> Bool -> String-showSBool (SN _ s) True  = "*" ++ unStanza s-showSBool (SN _ s) False = "!" ++ unStanza s--showQFN :: QFN -> String-showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f--showQSN :: QSN -> String-showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f
− Distribution/Client/Dependency/Modular/Index.hs 
@@ -1,52 +0,0 @@-module Distribution.Client.Dependency.Modular.Index-    ( Index-    , PInfo(..)-    , defaultQualifyOptions-    , mkIndex-    ) where--import Data.List as L-import Data.Map as M-import Prelude hiding (pi)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree--import Distribution.Client.ComponentDeps (Component)---- | 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, flags and failure reasons.--- 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 Component PN) FlagInfo (Maybe FailReason)-  deriving (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 _flagNfo _fr) <- M.toList is-                                -- .. and flatten all their dependencies ..-                              , (Dep dep _ci, _comp) <- flattenFlaggedDeps deps-                              ]-    , qoSetupIndependent = True-    }-  where-    base = PackageName "base"
− Distribution/Client/Dependency/Modular/IndexConversion.hs 
@@ -1,219 +0,0 @@-module Distribution.Client.Dependency.Modular.IndexConversion-    ( convPIs-    ) where--import Data.List as L-import Data.Map as M-import Data.Maybe-import Data.Monoid as Mon-import Prelude hiding (pi)--import qualified Distribution.Client.PackageIndex as CI-import Distribution.Client.Types-import Distribution.Client.ComponentDeps (Component(..))-import Distribution.Compiler-import Distribution.InstalledPackageInfo as IPI-import Distribution.Package                          -- from Cabal-import Distribution.PackageDescription as PD         -- from Cabal-import Distribution.PackageDescription.Configuration as PDC-import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System--import Distribution.Client.Dependency.Modular.Dependency as D-import Distribution.Client.Dependency.Modular.Flag as F-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.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 -> Bool -> Bool ->-           SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> Index-convPIs os arch comp sip strfl iidx sidx =-  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sidx)---- | Convert a Cabal installed package index to the simpler,--- more uniform index format of the solver.-convIPI' :: Bool -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]-convIPI' sip idx =-    -- apply shadowing whenever there are multiple installed packages with-    -- the same version-    [ maybeShadow (convIP idx pkg)-    | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx-    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]-  where--    -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))-    shadow x                                = x---- | Convert a single installed package into the solver-specific format.-convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)-convIP idx ipi =-  let ipid = IPI.installedUnitId ipi-      i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)-      pn = pkgName (sourcePackageId ipi)-  in  case mapM (convIPId pn idx) (IPI.depends ipi) of-        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))-        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)- where-  -- We assume that all dependencies of installed packages are _library_ deps-  setComp = setCompFlaggedDeps ComponentLib--- TODO: Installed packages should also store their encapsulations!---- | 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 :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN)-convIPId pn' idx ipid =-  case SI.lookupUnitId idx ipid of-    Nothing  -> Nothing-    Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)-                    pn = pkgName (sourcePackageId ipi)-                in  Just (D.Simple (Dep pn (Fixed i (P pn'))) ())---- | Convert a cabal-install source package index to the simpler,--- more uniform index format of the solver.-convSPI' :: OS -> Arch -> CompilerInfo -> Bool ->-            CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]-convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages---- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage -> (PN, I, PInfo)-convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =-  let i = I pv InRepo-  in  (pn, i, convGPD os arch cinfo strfl (PI pn i) gpd)---- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'--- 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 -> Bool ->-           PI PN -> GenericPackageDescription -> PInfo-convGPD os arch cinfo strfl pi-        (GenericPackageDescription pkg flags libs exes tests benchs) =-  let-    fds  = flagInfo strfl flags--    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-    conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo .-                        PDC.addBuildableCondition getInfo-  in-    PInfo-      (maybe []    (conv ComponentLib                     libBuildInfo         ) libs    ++-       maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)    ++-       concatMap   (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes    ++-      prefix (Stanza (SN pi TestStanzas))-        (L.map     (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)  ++-      prefix (Stanza (SN pi BenchStanzas))-        (L.map     (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs))-      fds-      Nothing--prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' 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 :: Bool -> [PD.Flag] -> FlagInfo-flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m))))---- | Convert condition trees to flagged dependencies.-convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->-                Component ->-                (a -> BuildInfo) ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo (CondNode info ds branches) =-                 L.map (\d -> D.Simple (convDep pn d) comp) ds  -- unconditional package dependencies-              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch os arch cinfo pi fds comp getInfo) branches-  where-    bi = getInfo info---- | Branch interpreter.------ 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.-convBranch :: OS -> Arch -> CompilerInfo ->-              PI PN -> FlagInfo ->-              Component ->-              (a -> BuildInfo) ->-              (Condition ConfVar,-               CondTree ConfVar [Dependency] a,-               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN-convBranch os arch cinfo pi@(PI pn _) fds comp getInfo (c', t', mf') =-  go c' (          convCondTree os arch cinfo pi fds comp getInfo   t')-        (maybe [] (convCondTree os arch cinfo pi fds comp getInfo) mf')-  where-    go :: Condition ConfVar ->-          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component 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 (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]-    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--    -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but without constraints. This heuristic together-    -- with deferring flag choices will then usually first resolve this package,-    -- and try an already installed version before imposing a default flag choice-    -- that might not be what we want.-    ---    -- Note that we make assumptions here on the form of the dependencies that-    -- can occur at this point. In particular, no occurrences of Fixed, and no-    -- occurrences of multiple version ranges, as all dependencies below this-    -- point have been generated using 'convDep'.-    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN-    extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp-                           | D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps-                           , D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps'-                           , pn1 == pn2-                           ]---- | Convert a Cabal dependency to a solver-specific dependency.-convDep :: PN -> Dependency -> Dep PN-convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, P pn')])---- | Convert setup dependencies-convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN-convSetupBuildInfo (PI pn _i) nfo =-    L.map (\d -> D.Simple (convDep pn d) ComponentSetup) (PD.setupDepends nfo)
− Distribution/Client/Dependency/Modular/Linking.hs 
@@ -1,574 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Distribution.Client.Dependency.Modular.Linking (-    addLinking-  , validateLinking-  ) where--import Prelude hiding (pi)-import Control.Exception (assert)-import Control.Monad.Reader-import Control.Monad.State-import Data.Maybe (catMaybes)-import Data.Map (Map, (!))-import Data.List (intercalate)-import Data.Set (Set)-import qualified Data.Map         as M-import qualified Data.Set         as S-import qualified Data.Traversable as T--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS--import Distribution.Client.Types (OptionalStanza(..))-import Distribution.Client.ComponentDeps (Component)--{--------------------------------------------------------------------------------  Add linking--------------------------------------------------------------------------------}--type RelatedGoals = Map (PN, I) [PP]-type Linker       = Reader RelatedGoals---- | Introduce link nodes into tree tree------ Linking is a traversal of the solver tree that adapts package choice nodes--- and adds the option to link wherever appropriate: Package goals are called--- "related" if they are for the same version 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.------ 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 a 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.-addLinking :: Tree QGoalReason -> Tree QGoalReason-addLinking = (`runReader` M.empty) .  cata go-  where-    go :: TreeF QGoalReason (Linker (Tree QGoalReason)) -> Linker (Tree QGoalReason)--    -- The only nodes of interest are package nodes-    go (PChoiceF qpn gr cs) = do-      env <- ask-      cs' <- T.sequence $ P.mapWithKey (goP qpn) cs-      let newCs = concatMap (linkChoices env qpn) (P.toList cs')-      return $ PChoice qpn gr (cs' `P.union` P.fromList newCs)-    go _otherwise =-      innM _otherwise--    -- Recurse underneath package choices. Here we just need to make sure-    -- that we record the package choice so that it is available below-    goP :: QPN -> POption -> Linker (Tree QGoalReason) -> Linker (Tree QGoalReason)-    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])-    goP _ _ = alreadyLinked--linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption, Tree QGoalReason)]-linkChoices related (Q _pp pn) (POption i Nothing, subtree) =-    map aux (M.findWithDefault [] (pn, i) related)-  where-    aux :: PP -> (POption, Tree QGoalReason)-    aux pp = (POption i (Just pp), subtree)-linkChoices _ _ (POption _ (Just _), _) =-    alreadyLinked--alreadyLinked :: a-alreadyLinked = error "addLinking called on tree that already contains linked nodes"--{--------------------------------------------------------------------------------  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-    }-    deriving Show--type Validate = Reader ValidateState---- | Validate linked packages------ Verify that linked packages have------ * Linked dependencies,--- * Equal flag assignments--- * Equal stanza assignments-validateLinking :: Index -> Tree QGoalReason -> Tree QGoalReason-validateLinking index = (`runReader` initVS) . cata go-  where-    go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason)--    go (PChoiceF qpn gr cs) =-      PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)-    go (FChoiceF qfn gr t m cs) =-      FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)-    go (SChoiceF qsn gr t cs) =-      SChoice qsn gr t   <$> T.sequence (P.mapWithKey (goS qsn) cs)--    -- For the other nodes we just recurse-    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs-    go (DoneF revDepMap)              = return $ Done revDepMap-    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason--    -- Package choices-    goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)-    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-      case execUpdateState (pickPOption qpn opt qdeps) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    -- Flag choices-    goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)-    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 QGoalReason) -> Validate (Tree QGoalReason)-    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-      }--{--------------------------------------------------------------------------------  Updating the validation state--------------------------------------------------------------------------------}--type Conflict = (ConflictSet QPN, 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-             assert (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 Component 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 -> PP -> FlaggedDeps Component 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 PP) -> 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 [] lgSource lgTarget-    updateLinkGroup lgTarget'--    -- Make sure all dependencies are linked as well-    linkDeps target [P qpn] 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 -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()-linkDeps target = \blame 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 blame deps rdeps-  where-    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()-    go = zipWithM_ . go1--    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()-    go1 blame dep rdep = case (dep, rdep) of-      (Simple (Dep qpn _) _, ~(Simple (Dep 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 blame 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 (F fn:blame) t t'-          Just False -> go (F fn:blame) 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 (S sn:blame) 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 for pkg-config constraints.-      (Simple (Ext  _)   _, _) -> return ()-      (Simple (Lang _)   _, _) -> return ()-      (Simple (Pkg  _ _) _, _) -> return ()--    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component 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 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), Just i) = varPI var-        PInfo deps _ _          = vsIndex vs ! pn ! i-        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps-        lg                      = vsLinks vs ! qpn-        (parents, newDeps)      = findNewDeps vs qdeps-        linkedTo                = S.delete pp (lgMembers lg)-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps-  where-    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps vs = concatMapUnzip (findNewDeps' vs)--    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)-    findNewDeps' _  (Simple _ _)        = ([], [])-    findNewDeps' vs (Flagged qfn _ t f) =-      case (F qfn == var, M.lookup qfn (vsFlags vs)) of-        (True, _)    -> ([F qfn], if b then t else f)-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)-                        in (F qfn:parents, deps)-    findNewDeps' vs (Stanza qsn t) =-      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of-        (True, _)    -> ([S qsn], if b then t else [])-        (_, Nothing) -> ([], []) -- not yet known-        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])-                        in (S qsn:parents, deps)--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 finfo _ = vsIndex vs ! lgPackage lg ! i-            flags   = M.keys finfo-            stanzas = [TestStanzas, BenchStanzas]-        forM_ flags $ \fn -> do-          let flag = FN (PI (lgPackage lg) i) fn-          verifyFlag' flag lg-        forM_ stanzas $ \sn -> do-          let stanza = SN (PI (lgPackage lg) i) sn-          verifyStanza' stanza lg--verifyFlag :: QFN -> UpdateState ()-verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do-    vs <- get-    -- We can only pick a flag after picking an instance; link group must exist-    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)--verifyStanza :: QSN -> UpdateState ()-verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do-    vs <- get-    -- We can only pick a stanza after picking an instance; link group must exist-    verifyStanza' (SN (PI pn i) 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 (PI pn i) fn) lg = do-    vs <- get-    let flags = map (\pp' -> FN (PI (Q pp' pn) i) 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 " ++ show 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 (PI pn i) sn) lg = do-    vs <- get-    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) 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 " ++ show 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 PP)--      -- | The members of the link group-    , lgMembers :: Set PP--      -- | 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 QPN-    }-    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 :: PP -> 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 :: PP -> QPN-    qpn pp = Q pp (lgPackage lg)---- | Creates a link group that contains a single member.-lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup-lgSingleton (Q pp pn) canon = LinkGroup {-      lgPackage = pn-    , lgCanon   = canon-    , lgMembers = S.singleton pp-    , lgBlame   = CS.empty-    }--lgMerge :: [Var QPN] -> 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 [CS.fromList 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 [-                               CS.fromList blame-                             , lgConflictSet lg-                             , lgConflictSet lg'-                             ]-                          ,    "cannot merge " ++ showLinkGroup lg-                            ++ " and " ++ showLinkGroup lg'-                          )--lgConflictSet :: LinkGroup -> ConflictSet QPN-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)--concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])-concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f
− Distribution/Client/Dependency/Modular/Log.hs 
@@ -1,106 +0,0 @@-module Distribution.Client.Dependency.Modular.Log-    ( Log-    , continueWith-    , failWith-    , logToProgress-    , succeedWith-    , tryWith-    ) where--import Control.Applicative-import Data.List as L-import Data.Maybe (isNothing)--import Distribution.Client.Dependency.Types -- from Cabal--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree (FailReason(..))-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS---- | The 'Log' datatype.------ Represents the progress of a computation lazily.------ Parameterized over the type of actual messages and the final result.-type Log m a = Progress m () a--messages :: Progress step fail done -> [step]-messages = foldProgress (:) (const []) (const [])---- | Postprocesses a log file. 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.-logToProgress :: Maybe Int -> Log Message a -> Progress String String a-logToProgress mbj l = let-                        es = proc (Just 0) l -- catch first error (always)-                        ms = useFirstError (proc mbj l)-                      in go es es -- trace for first error-                            (showMessages (const True) True ms) -- run with backjump limit applied-  where-    -- Proc takes the allowed number of backjumps and a 'Progress' and explores the-    -- messages until the maximum number of backjumps has been reached. It filters out-    -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates-    -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the-    -- original success result or replaces the original failure with 'Nothing'.-    proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b-    proc _        (Done x)                          = Done x-    proc _        (Fail _)                          = Fail Nothing-    proc mbj'     (Step   (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))-      | cs == cs'                                   = proc mbj' xs -- repeated backjumps count as one-    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (Just cs)-    proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)-    proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs)--    -- Sets the conflict set from the first backjump as the final error, and records-    -- whether the search was exhaustive.-    useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b-                  -> Progress Message (Bool, Maybe (ConflictSet QPN)) b-    useFirstError = replace Nothing-      where-        replace _       (Done x)                          = Done x-        replace cs'     (Fail cs)                         = -- 'Nothing' means backjump limit not reached.-                                                            -- Prefer first error over later error.-                                                            Fail (isNothing cs, cs' <|> cs)-        replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs-        replace cs'     (Step x                       xs) = Step x $ replace cs' xs--    -- The first two arguments are both supposed to be the log up to the first error.-    -- That's the error that will always be printed in case we do not find a solution.-    -- We pass this log twice, because we evaluate it in parallel with the full log,-    -- but we also want to retain the reference to its beginning for when we print it.-    -- This trick prevents a space leak!-    ---    -- The third argument is the full log, ending with either the solution or the-    -- exhaustiveness and first conflict set.-    go :: Progress Message a b-       -> Progress Message a b-       -> Progress String (Bool, Maybe (ConflictSet QPN)) b-       -> Progress String String b-    go ms (Step _ ns) (Step x xs)           = Step x (go ms ns xs)-    go ms r           (Step x xs)           = Step x (go ms r  xs)-    go ms _           (Fail (exh, Just cs)) = Fail $-                                              "Could not resolve dependencies:\n" ++-                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++-                                              (if exh then "Dependency tree exhaustively searched.\n"-                                                      else "Backjump limit reached (" ++ currlimit mbj ++-                                                               "change with --max-backjumps or try to run with --reorder-goals).\n")-                                                  where currlimit (Just n) = "currently " ++ show n ++ ", "-                                                        currlimit Nothing  = ""-    go _  _           (Done s)              = Done s-    go _  _           (Fail (_, Nothing))   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen--failWith :: step -> fail -> Progress step fail done-failWith s f = Step s (Fail f)--succeedWith :: step -> done -> Progress step fail done-succeedWith s d = Step s (Done d)--continueWith :: step -> Progress step fail done -> Progress step fail done-continueWith = Step--tryWith :: Message-        -> Progress Message fail done-        -> Progress Message fail done-tryWith m = Step m . Step Enter . foldProgress Step (failWith Leave) Done
− Distribution/Client/Dependency/Modular/Message.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Distribution.Client.Dependency.Modular.Message (-    Message(..),-    showMessages-  ) where--import qualified Data.List as L-import Prelude hiding (pi)--import Distribution.Text -- from Cabal--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.Tree-         ( FailReason(..), POption(..) )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..), showConstraintSource, Progress(..) )--data Message =-    Enter           -- ^ increase indentation level-  | Leave           -- ^ decrease indentation level-  | TryP QPN POption-  | TryF QFN Bool-  | TryS QSN Bool-  | Next (Goal QPN)-  | Success-  | Failure (ConflictSet QPN) FailReason---- | Transforms the structured message type to actual messages (strings).------ Takes an additional relevance predicate. The predicate gets a stack of goal--- variables and can decide whether messages regarding these goals are relevant.--- You can plug in 'const True' if you're interested in a full trace. If you--- want a slice of the trace concerning a particular conflict set, then plug in--- a predicate returning 'True' on the empty stack and if the head is in the--- conflict set.------ The second argument indicates if the level numbers should be shown. This is--- recommended for any trace that involves backtracking, because only the level--- numbers will allow to keep track of backjumps.-showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b-showMessages p sl = go [] 0-  where-    -- The stack 'v' represents variables that are currently assigned by the-    -- solver.  'go' pushes a variable for a recursive call when it encounters-    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.-    -- When 'go' processes a package goal, or a package goal followed by a-    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the-    -- stack so that the predicate can also select messages relating to package-    -- goal choices.-    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b-    go !_ !_ (Done x)                           = Done x-    go !_ !_ (Fail x)                           = Fail x-    -- complex patterns-    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        goPReject v l qpn [i] c fr ms-    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) =-        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms-        -- the previous case potentially arises in the error output, because we remove the backjump itself-        -- if we cut the log after the first error-    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) =-        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms-    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =-        let v' = add (P qpn) v-        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)-    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))-        | c == c' = go v l ms-    -- standard display-    go !v !l (Step Enter                    ms) = go v          (l+1) ms-    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms-    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)-    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)-    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)-    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)-    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log-    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)-    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v l ms)--    showPackageGoal :: QPN -> QGoalReason -> String-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr--    showFailure :: ConflictSet QPN -> FailReason -> String-    showFailure c fr = "fail" ++ showFR c fr--    add :: Var QPN -> [Var QPN] -> [Var QPN]-    add v vs = simplifyVar v : vs--    -- special handler for many subsequent package rejections-    goPReject :: [Var QPN]-              -> Int-              -> QPN-              -> [POption]-              -> ConflictSet QPN-              -> FailReason-              -> Progress Message a b-              -> Progress String a b-    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms-    goPReject v l qpn is c fr ms =-        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)--    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level-    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b-    atLevel v l x xs-      | sl && p v = let s = show l-                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs-      | p v       = Step x xs-      | otherwise = xs--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 (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"-showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"-showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"--showFR :: ConflictSet QPN -> FailReason -> String-showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"-showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"-showFR _ CannotInstall                    = " (only already installed instances can be used)"-showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"-showFR _ Shadowed                         = " (shadowed by another installed package with same version)"-showFR _ Broken                           = " (package is broken)"-showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display 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: " ++ showCS c ++ ")"-showFR _ MultipleInstances                = " (multiple instances)"-showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"-showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")"--- 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)"--constraintSource :: ConstraintSource -> String-constraintSource src = "constraint from " ++ showConstraintSource src
− Distribution/Client/Dependency/Modular/PSQ.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.PSQ-    ( PSQ(..)  -- Unit test needs constructor access-    , Degree(..)-    , casePSQ-    , cons-    , degree-    , delete-    , dminimumBy-    , length-    , lookup-    , filter-    , filterKeys-    , firstOnly-    , fromList-    , isZeroOrOne-    , keys-    , map-    , mapKeys-    , mapWithKey-    , mapWithKeyState-    , minimumBy-    , null-    , prefer-    , preferByKeys-    , preferOrElse-    , snoc-    , sortBy-    , sortByKeys-    , splits-    , 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)--mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b-mapWithKeyState p (PSQ xs) s0 =-  PSQ (F.foldr (\ (k, v) r s -> case p s k v of-                                  (w, n) -> (k, w) : (r n))-               (const []) xs s0)--delete :: Eq k => k -> PSQ k a -> PSQ k a-delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) 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)--splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits = go id-  where-    go f xs = casePSQ xs-        (PSQ [])-        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) 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)---- | Given a measure in form of a pseudo-peano-natural number,--- determine the approximate minimum. This is designed to stop--- even traversing the list as soon as we find any element with--- measure 'ZeroOrOne'.------ Always returns a one-element queue (except if the queue is--- empty, then we return an empty queue again).----dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a-dminimumBy _   (PSQ [])       = PSQ []-dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs-  where-    go ZeroOrOne v _ = PSQ [v]-    go _ v []        = PSQ [v]-    go c v (y : ys)  = case compare c d of-      LT -> go c v ys-      EQ -> go c v ys-      GT -> go d y ys-      where-        d = sel (snd y)--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))]---- | 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.----prefer :: (a -> Bool) -> PSQ k a -> PSQ k a-prefer p (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then PSQ con else PSQ pro---- | Variant of 'prefer' that takes a continuation for the case--- that there are none of the desired elements.-preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a-preferOrElse p k (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then k (PSQ con) else PSQ pro---- | Variant of 'prefer' that takes a predicate on the keys--- rather than on the values.----preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-preferByKeys 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---- | Approximation of the branching degree.------ This is designed for computing the branching degree of a goal choice--- node. If the degree is 0 or 1, it is always good to take that goal,--- because we can either abort immediately, or have no other choice anyway.------ So we do not actually want to compute the full degree (which is--- somewhat costly) in cases where we have such an easy choice.----data Degree = ZeroOrOne | Two | Other-  deriving (Show, Eq)--instance Ord Degree where-  compare ZeroOrOne _         = LT -- lazy approximation-  compare _         ZeroOrOne = GT -- approximation-  compare Two       Two       = EQ-  compare Two       Other     = LT-  compare Other     Two       = GT-  compare Other     Other     = EQ--degree :: PSQ k a -> Degree-degree (PSQ [])     = ZeroOrOne-degree (PSQ [_])    = ZeroOrOne-degree (PSQ [_, _]) = Two-degree (PSQ _)      = Other--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/Client/Dependency/Modular/Package.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Package-  ( I(..)-  , Loc(..)-  , PackageId-  , PackageIdentifier(..)-  , PackageName(..)-  , PI(..)-  , PN-  , PP(..)-  , Namespace(..)-  , Qualifier(..)-  , QPN-  , QPV-  , Q(..)-  , instI-  , makeIndependent-  , primaryPP-  , showI-  , showPI-  , showQPN-  , unPN-  ) where--import Data.List as L--import Distribution.Package -- from Cabal-import Distribution.Text    -- from Cabal--import Distribution.Client.Dependency.Modular.Version---- | A package name.-type PN = PackageName---- | Unpacking a package name.-unPN :: PN -> String-unPN (PackageName pn) = pn---- | Package version. A package name plus a version number.-type PV = PackageId---- | Qualified package version.-type QPV = Q 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" ++ shortId uid-  where-    -- A hack to extract the beginning of the package ABI hash-    shortId (SimpleUnitId (ComponentId i))-            = snip (splitAt 4) (++ "...")-            . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)-            $ i-    snip p f xs = case p xs of-                    (ys, zs) -> (if L.null zs then id else f) 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---- | A package path consists of a namespace and a package path inside that--- namespace.-data PP = PP 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--    -- | Independent namespace-    ---    -- For now we just number these (rather than giving them more structure).-  | Independent Int-  deriving (Eq, Ord, Show)---- | Qualifier of a package within a namespace (see 'PP')-data Qualifier =-    -- | Top-level dependency in this namespace-    Unqualified--    -- | Any dependency on base is considered independent-    ---    -- This makes it possible to have base shims.-  | Base PN--    -- | 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).-  | Setup PN-  deriving (Eq, Ord, Show)---- | Is the package in the primary group of packages. In particular this--- does not include packages pulled in as setup deps.----primaryPP :: PP -> Bool-primaryPP (PP _ns q) = go q-  where-    go Unqualified = True-    go (Base  _)   = True-    go (Setup _)   = False---- | String representation of a package path.------ NOTE: The result of 'showPP' is either empty or results in a period, so that--- it can be prepended to a package name.-showPP :: PP -> String-showPP (PP ns q) =-    case ns of-      DefaultNamespace -> go q-      Independent i    -> show i ++ "." ++ go q-  where-    -- Print the qualifier-    ---    -- 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@).-    go Unqualified = ""-    go (Setup pn)  = display pn ++ "-setup."-    go (Base  pn)  = display pn ++ "."---- | A qualified entity. Pairs a package path with the entity.-data Q a = Q PP a-  deriving (Eq, Ord, Show)---- | Standard string representation of a qualified entity.-showQ :: (a -> String) -> (Q a -> String)-showQ showa (Q pp x) = showPP pp ++ showa x---- | Qualified package name.-type QPN = Q PN---- | String representation of a qualified package path.-showQPN :: QPN -> String-showQPN = showQ display---- | Create artificial parents for each of the package names, making--- them all independent.-makeIndependent :: [PN] -> [QPN]-makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]-                               , let pp = PP (Independent i) Unqualified-                     ]
− Distribution/Client/Dependency/Modular/Preference.hs 
@@ -1,397 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Preference-    ( avoidReinstalls-    , deferSetupChoices-    , deferWeakFlagChoices-    , enforceManualFlags-    , enforcePackageConstraints-    , enforceSingleInstanceRestriction-    , firstGoal-    , preferBaseGoalChoice-    , preferEasyGoalChoices-    , preferLinked-    , preferPackagePreferences-    , preferReallyEasyGoalChoices-    , requireInstalled-    ) where---- Reordering or pruning the tree in order to prefer or make certain choices.--import qualified Data.List as L-import qualified Data.Map as M-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-import Control.Applicative-#endif-import Prelude hiding (sequence)-import Control.Monad.Reader hiding (sequence)-import Data.Map (Map)-import Data.Traversable (sequence)--import Distribution.Client.Dependency.Types-  ( PackageConstraint(..), LabeledPackageConstraint(..), ConstraintSource(..)-  , PackagePreferences(..), InstalledPreference(..) )-import Distribution.Client.Types-  ( OptionalStanza(..) )--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.Modular.Version-import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS---- | Generic abstraction for strategies that just rearrange the package order.--- Only packages that match the given predicate are reordered.-packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a-packageOrderFor p cmp' = trav go-  where-    go (PChoiceF v@(Q _ pn) r cs)-      | p pn                        = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)-      | otherwise                   = PChoiceF v r                               cs-    go x                            = x--    cmp :: PN -> POption -> POption -> Ordering-    cmp pn (POption i _) (POption i' _) = cmp' pn i i'---- | Prefer to link packages whenever possible-preferLinked :: Tree a -> Tree a-preferLinked = trav go-  where-    go (PChoiceF qn a  cs) = PChoiceF qn a (P.sortByKeys cmp cs)-    go x                   = x--    cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo'--    cmpL Nothing  Nothing  = EQ-    cmpL Nothing  (Just _) = GT-    cmpL (Just _) Nothing  = LT-    cmpL (Just _) (Just _) = EQ---- | Ordering that treats versions satisfying more preferred ranges as greater---   than versions satisfying less preferred ranges.-preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering-preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2)-  where-     check v = Prelude.length . Prelude.filter (==True) .-               Prelude.map (flip checkVR v) $ vrs---- | Traversal that tries to establish package preferences (not constraints).--- Works by reordering choice nodes. Also applies stanza preferences.-preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackagePreferences pcs = preferPackageStanzaPreferences pcs-                             . packageOrderFor (const True) preference-  where-    preference pn i1@(I v1 _) i2@(I v2 _) =-      let PackagePreferences vrs ipref _ = pcs pn-      in  preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically-          locationsOrdering ipref i1 i2--    -- Note that we always rank installed before uninstalled, and later-    -- versions before earlier, but we can change the priority of the-    -- two orderings.-    locationsOrdering PreferInstalled v1 v2 =-      preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2-    locationsOrdering PreferLatest v1 v2 =-      preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2---- | Ordering that treats installed instances as greater than uninstalled ones.-preferInstalledOrdering :: I -> I -> Ordering-preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ-preferInstalledOrdering (I _ (Inst _)) _              = GT-preferInstalledOrdering _              (I _ (Inst _)) = LT-preferInstalledOrdering _              _              = EQ---- | Compare instances by their version numbers.-preferLatestOrdering :: I -> I -> Ordering-preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2---- | Traversal that tries to establish package stanza enable\/disable--- preferences. Works by reordering the branches of stanza choices.-preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackageStanzaPreferences pcs = trav go-  where-    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) | primaryPP pp =-        let PackagePreferences _ _ spref = pcs pn-            enableStanzaPref = s `elem` spref-                  -- move True case first to try enabling the stanza-            ts' | enableStanzaPref = P.sortByKeys (flip compare) ts-                | otherwise        = ts-         in SChoiceF qsn gr True ts'   -- True: now weak choice-    go x = x---- | 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 :: PP-                          -> ConflictSet QPN-                          -> I-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r-  | src == ConstraintSourceUserTarget && not (primaryPP pp)         = r-    -- the constraints arising from targets, like "foo-1.0" only apply to-    -- the main packages in the solution, they don't constrain setup deps--processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc-  where-    go (I v _) (PackageConstraintVersion _ vr)-        | checkVR vr v  = r-        | otherwise     = Fail c (GlobalConstraintVersion vr src)-    go _       (PackageConstraintInstalled _)-        | instI i       = r-        | otherwise     = Fail c (GlobalConstraintInstalled src)-    go _       (PackageConstraintSource    _)-        | 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 :: Flag-                          -> ConflictSet QPN-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc-  where-    go (PackageConstraintFlags _ fa) =-        case L.lookup 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 :: OptionalStanza-                          -> ConflictSet QPN-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree a-                          -> Tree a-processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc-  where-    go (PackageConstraintStanzas _ 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 QGoalReason-                          -> Tree QGoalReason-enforcePackageConstraints pcs = trav go-  where-    go (PChoiceF qpn@(Q pp pn)              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 pp c i pc) id-                           (M.findWithDefault [] pn pcs)-      in PChoiceF qpn gr      (P.mapWithKey g ts)-    go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =-      let c = varToConflictSet (F qfn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id-                           (M.findWithDefault [] pn pcs)-      in FChoiceF qfn gr tr m (P.mapWithKey g ts)-    go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) 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 f c b pc) id-                           (M.findWithDefault [] pn pcs)-      in SChoiceF qsn gr tr   (P.mapWithKey g ts)-    go x = x---- | Transformation that tries to enforce manual flags. Manual flags--- can only be re-set explicitly by the user. This transformation should--- be run after user preferences have been enforced. For manual flags,--- it checks if a user choice has been made. If not, it disables all but--- the first choice.-enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason-enforceManualFlags = trav go-  where-    go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $-      let c = varToConflictSet (F qfn)-      in  case span isDisabled (P.toList ts) of-            ([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)-            _            -> ts -- something has been manually selected, leave things alone-      where-        isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True-        isDisabled _                                    = False-    go x                                                   = x---- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason-requireInstalled p = trav go-  where-    go (PChoiceF v@(Q _ pn) gr cs)-      | p pn      = PChoiceF v gr (P.mapWithKey installed cs)-      | otherwise = PChoiceF v 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 QGoalReason -> Tree QGoalReason-avoidReinstalls p = trav go-  where-    go (PChoiceF qpn@(Q _ pn) gr cs)-      | p pn      = PChoiceF qpn gr disableReinstalls-      | otherwise = PChoiceF qpn gr cs-      where-        disableReinstalls =-          let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ]-          in  P.mapWithKey (notReinstall installed) cs--        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =-          Fail (varToConflictSet (P qpn)) CannotReinstall-        notReinstall _ _ x =-          x-    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 a -> Tree a-firstGoal = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (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. 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 a -> Tree a-preferBaseGoalChoice = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)-    go x                = x--    isBase :: OpenGoal comp -> Bool-    isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True-    isBase _                                                              = False---- | Deal with setup dependencies after regular dependencies, so that we can--- will link setup depencencies against package dependencies when possible-deferSetupChoices :: Tree a -> Tree a-deferSetupChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)-    go x                = x--    noSetup :: OpenGoal comp -> Bool-    noSetup (OpenGoal (Simple (Dep (Q (PP _ns (Setup _)) _) _) _) _) = 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 a -> Tree a-deferWeakFlagChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))-    go x                = x--    noWeakStanza :: Tree a -> Bool-    noWeakStanza (SChoice _ _ True _) = False-    noWeakStanza _                    = True--    noWeakFlag :: Tree a -> Bool-    noWeakFlag (FChoice _ _ True _ _) = False-    noWeakFlag _                      = True---- | Transformation that sorts choice nodes so that--- child nodes with a small branching degree are preferred.------ Only approximates the number of choices in the branches.--- In particular, we try to take any goal immediately if it has--- a branching degree of 0 (guaranteed failure) or 1 (no other--- choice possible).------ Returns at most one choice.----preferEasyGoalChoices :: Tree a -> Tree a-preferEasyGoalChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)-      -- (a different implementation that seems slower):-      -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs))-    go x                = x---- | A variant of 'preferEasyGoalChoices' that just keeps the--- ones with a branching degree of 0 or 1. Note that unlike--- 'preferEasyGoalChoices', this may return more than one--- choice.----preferReallyEasyGoalChoices :: Tree a -> Tree a-preferReallyEasyGoalChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.prefer 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 QGoalReason -> Tree QGoalReason-enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go-  where-    go :: TreeF QGoalReason (EnforceSIR (Tree QGoalReason)) -> EnforceSIR (Tree QGoalReason)--    -- We just verify package choices.-    go (PChoiceF qpn gr cs) =-      PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)-    go _otherwise =-      innM _otherwise--    -- The check proper-    goP :: QPN -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason)-    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/Client/Dependency/Modular/Solver.hs 
@@ -1,100 +0,0 @@-module Distribution.Client.Dependency.Modular.Solver-    ( SolverConfig(..)-    , solve-    ) where--import Data.Map as M--import Distribution.Compiler (CompilerInfo)--import Distribution.Client.PkgConfigDb (PkgConfigDb)--import Distribution.Client.Dependency.Types--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Builder-import Distribution.Client.Dependency.Modular.Cycles-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Explore-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Log-import Distribution.Client.Dependency.Modular.Message-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.Preference as P-import Distribution.Client.Dependency.Modular.Validate-import Distribution.Client.Dependency.Modular.Linking---- | Various options for the modular solver.-data SolverConfig = SolverConfig {-  preferEasyGoalChoices :: Bool,-  independentGoals      :: Bool,-  avoidReinstalls       :: Bool,-  shadowPkgs            :: Bool,-  strongFlags           :: Bool,-  maxBackjumps          :: Maybe Int-}---- | 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.------ Semantically, there is no difference. Cycle detection, as implemented--- now, only occurs for 'Done' nodes we encounter during exploration,--- and cycle detection itself does not change the shape of the tree,--- it only marks some 'Done' nodes as 'Fail', if they contain cyclic--- solutions.------ There is a tiny performance impact, however, in doing cycle detection--- directly after validation. Probably because cycle detection maintains--- some information, and the various reorderings implemented by--- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more--- costly if that information is already around during the reorderings.------ With the current positioning directly before the 'explorePhase', there--- seems to be no statistically significant performance impact of cycle--- detection in the common case where there are no cycles.----solve :: SolverConfig ->                      -- ^ solver parameters-         CompilerInfo ->-         Index ->                             -- ^ all available packages as an index-         PkgConfigDb ->                       -- ^ available pkg-config pkgs-         (PN -> PackagePreferences) ->        -- ^ preferences-         Map PN [LabeledPackageConstraint] -> -- ^ global constraints-         [PN] ->                              -- ^ global goals-         Log Message (Assignment, RevDepMap)-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =-  explorePhase     $-  detectCyclesPhase$-  heuristicsPhase  $-  preferencesPhase $-  validationPhase  $-  prunePhase       $-  buildPhase-  where-    explorePhase     = backjumpAndExplore-    heuristicsPhase  = (if preferEasyGoalChoices sc-                         then P.preferEasyGoalChoices -- also leaves just one choice-                         else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)-                       P.deferWeakFlagChoices .-                       P.deferSetupChoices .-                       P.preferBaseGoalChoice .-                       P.preferLinked-    preferencesPhase = P.preferPackagePreferences userPrefs-    validationPhase  = P.enforceManualFlags . -- can only be done after user constraints-                       P.enforcePackageConstraints userConstraints .-                       P.enforceSingleInstanceRestriction .-                       validateLinking idx .-                       validateTree cinfo idx pkgConfigDB-    prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .-                       -- packages that can never be "upgraded":-                       P.requireInstalled (`elem` [ PackageName "base"-                                                  , PackageName "ghc-prim"-                                                  , PackageName "integer-gmp"-                                                  , PackageName "integer-simple"-                                                  ])-    buildPhase       = addLinking $ buildTree idx (independentGoals sc) userGoals
− Distribution/Client/Dependency/Modular/Tree.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.Tree-    ( FailReason(..)-    , POption(..)-    , Tree(..)-    , TreeF(..)-    , ana-    , cata-    , choices-    , dchoices-    , inn-    , innM-    , para-    , trav-    , zeroOrOneChoices-    ) where--import Control.Monad hiding (mapM, sequence)-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr, mapM, sequence)--import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ (PSQ)-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Version-import Distribution.Client.Dependency.Types ( ConstraintSource(..) )---- | Type of the search tree. Inlining the choice nodes for now.-data Tree a =-    PChoice     QPN a           (PSQ POption       (Tree a))-  | FChoice     QFN a Bool Bool (PSQ Bool          (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual-  | SChoice     QSN a Bool      (PSQ Bool          (Tree a)) -- Bool indicates whether it's trivial-  | GoalChoice                  (PSQ (OpenGoal ()) (Tree a)) -- PSQ should never be empty-  | Done        RevDepMap-  | Fail        (ConflictSet QPN) FailReason-  deriving (Eq, Show, Functor)-  -- Above, a choice is called trivial if it clearly does not matter. The-  -- special case of triviality we actually consider is if there are no new-  -- dependencies introduced by this node.-  ---  -- A (flag) choice is called weak if we do want to defer it. This is the-  -- case for flags that should be implied by what's currently installed on-  -- the system, as opposed to flags that are used to explicitly enable or-  -- disable some functionality.---- | 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). Teans 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 PP)-  deriving (Eq, Show)--data FailReason = InconsistentInitialConstraints-                | Conflicting [Dep QPN]-                | CannotInstall-                | CannotReinstall-                | Shadowed-                | Broken-                | GlobalConstraintVersion VR ConstraintSource-                | GlobalConstraintInstalled ConstraintSource-                | GlobalConstraintSource ConstraintSource-                | GlobalConstraintFlag ConstraintSource-                | ManualFlag-                | MalformedFlagChoice QFN-                | MalformedStanzaChoice QSN-                | EmptyGoalChoice-                | Backjump-                | MultipleInstances-                | DependenciesNotLinked String-                | CyclicDependencies-  deriving (Eq, Show)---- | Functor for the tree type.-data TreeF a b =-    PChoiceF    QPN a           (PSQ POption       b)-  | FChoiceF    QFN a Bool Bool (PSQ Bool          b)-  | SChoiceF    QSN a Bool      (PSQ Bool          b)-  | GoalChoiceF                 (PSQ (OpenGoal ()) b)-  | DoneF       RevDepMap-  | FailF       (ConflictSet QPN) FailReason-  deriving (Functor, Foldable, Traversable)--out :: Tree a -> TreeF a (Tree a)-out (PChoice    p i     ts) = PChoiceF    p i     ts-out (FChoice    p i b m ts) = FChoiceF    p i b m ts-out (SChoice    p i b   ts) = SChoiceF    p i b   ts-out (GoalChoice         ts) = GoalChoiceF         ts-out (Done       x         ) = DoneF       x-out (Fail       c x       ) = FailF       c x--inn :: TreeF a (Tree a) -> Tree a-inn (PChoiceF    p i     ts) = PChoice    p i     ts-inn (FChoiceF    p i b m ts) = FChoice    p i b m ts-inn (SChoiceF    p i b   ts) = SChoice    p i b   ts-inn (GoalChoiceF         ts) = GoalChoice         ts-inn (DoneF       x         ) = Done       x-inn (FailF       c x       ) = Fail       c x--innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)-innM (PChoiceF    p i     ts) = liftM (PChoice    p i    ) (sequence ts)-innM (FChoiceF    p i b m ts) = liftM (FChoice    p i b m) (sequence ts)-innM (SChoiceF    p i b   ts) = liftM (SChoice    p i b  ) (sequence ts)-innM (GoalChoiceF         ts) = liftM (GoalChoice        ) (sequence ts)-innM (DoneF       x         ) = return $ Done     x-innM (FailF       c x       ) = return $ Fail     c x---- | Determines whether a tree is active, i.e., isn't a failure node.-active :: Tree a -> Bool-active (Fail _ _) = False-active _          = True---- | Determines how many active choices are available in a node. Note that we--- count goal choices as having one choice, always.-choices :: Tree a -> Int-choices (PChoice    _ _     ts) = P.length (P.filter active ts)-choices (FChoice    _ _ _ _ ts) = P.length (P.filter active ts)-choices (SChoice    _ _ _   ts) = P.length (P.filter active ts)-choices (GoalChoice         _ ) = 1-choices (Done       _         ) = 1-choices (Fail       _ _       ) = 0---- | Variant of 'choices' that only approximates the number of choices.-dchoices :: Tree a -> P.Degree-dchoices (PChoice    _ _     ts) = P.degree (P.filter active ts)-dchoices (FChoice    _ _ _ _ ts) = P.degree (P.filter active ts)-dchoices (SChoice    _ _ _   ts) = P.degree (P.filter active ts)-dchoices (GoalChoice         _ ) = P.ZeroOrOne-dchoices (Done       _         ) = P.ZeroOrOne-dchoices (Fail       _ _       ) = P.ZeroOrOne---- | Variant of 'choices' that only approximates the number of choices.-zeroOrOneChoices :: Tree a -> Bool-zeroOrOneChoices (PChoice    _ _     ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (FChoice    _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (SChoice    _ _ _   ts) = P.isZeroOrOne (P.filter active ts)-zeroOrOneChoices (GoalChoice         _ ) = True-zeroOrOneChoices (Done       _         ) = True-zeroOrOneChoices (Fail       _ _       ) = True---- | Catamorphism on trees.-cata :: (TreeF a b -> b) -> Tree a -> b-cata phi x = (phi . fmap (cata phi) . out) x--trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b-trav psi x = cata (inn . psi) x---- | Paramorphism on trees.-para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b-para phi = phi . fmap (\ x -> (para phi x, x)) . out---- | Anamorphism on trees.-ana :: (b -> TreeF a b) -> b -> Tree a-ana psi = inn . fmap (ana psi) . psi
− Distribution/Client/Dependency/Modular/Validate.hs 
@@ -1,269 +0,0 @@-module Distribution.Client.Dependency.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.List as L-import Data.Map as M-import Data.Set as S-import Data.Traversable-import Prelude hiding (sequence)--import Language.Haskell.Extension (Extension, Language)--import Distribution.Compiler (CompilerInfo(..))--import Distribution.Client.Dependency.Modular.Assignment-import Distribution.Client.Dependency.Modular.Dependency-import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index-import Distribution.Client.Dependency.Modular.Package-import qualified Distribution.Client.Dependency.Modular.PSQ as P-import Distribution.Client.Dependency.Modular.Tree-import Distribution.Client.Dependency.Modular.Version (VR)--import Distribution.Client.ComponentDeps (Component)-import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)---- 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 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   :: PN -> VR  -> Bool,-  index :: Index,-  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies-  pa    :: PreAssignment,-  qualifyOptions :: QualifyOptions-}--type Validate = Reader ValidateState--validate :: Tree QGoalReason -> Validate (Tree QGoalReason)-validate = cata go-  where-    go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason)--    go (PChoiceF qpn gr     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) ts)-    go (FChoiceF qfn gr b m 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 P.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 gr b m <$> sequence (P.mapWithKey (goF qfn) ts)-    go (SChoiceF qsn 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 P.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 gr b <$> sequence (P.mapWithKey (goS qsn) ts)--    -- We don't need to do anything for goal choices or failure nodes.-    go (GoalChoiceF              ts) = GoalChoice <$> sequence ts-    go (DoneF    rdm               ) = pure (Done rdm)-    go (FailF    c fr              ) = pure (Fail c fr)--    -- What to do for package nodes ...-    goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)-    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-      qo             <- asks qualifyOptions-      -- obtain dependencies and index-dictated exclusions introduced by the choice-      let (PInfo deps _ 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 = Dep qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps)-      -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives-      -- 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)-        _       -> case mnppa of-                     Left (c, d) -> -- We have an inconsistency. We can stop.-                                    return (Fail c (Conflicting d))-                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.-                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r--    -- What to do for flag nodes ...-    goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)-    goF qfn@(FN (PI qpn _i) _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-      -- 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-      -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r--    -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)-    goS qsn@(SN (PI qpn _i) _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-      -- 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-      -- As in the package case, we try to extend the partial assignment.-      case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of-        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found-        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r---- | 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.-extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]-extractDeps 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  -> extractDeps fa sa td-                             Just False -> extractDeps fa sa fd-    Stanza qsn td       -> case M.lookup qsn sa of-                             Nothing    -> mzero-                             Just True  -> extractDeps 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--- 'extractDeps' for everything underneath.-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]-extractNewDeps v b fa sa = go-  where-    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)-    go deps = do-      d <- deps-      case d of-        Simple _ _           -> mzero-        Flagged qfn' _ td fd-          | v == F qfn'      -> L.map (resetVar v) $-                                if b then extractDeps fa sa td else extractDeps 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'      -> L.map (resetVar v) $-                                if b then extractDeps fa sa td else []-          | otherwise        -> case M.lookup qsn' sa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> []---- | Interface.-validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree QGoalReason -> Tree QGoalReason-validateTree cinfo idx pkgConfigDb t = runReader (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-  , qualifyOptions = defaultQualifyOptions idx-  }
− Distribution/Client/Dependency/Modular/Var.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Var (-    Var(..)-  , simplifyVar-  , showVar-  , varPI-  ) where--import Prelude hiding (pi)--import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Package--{--------------------------------------------------------------------------------  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)---- | For computing conflict sets, we map flag choice vars to a--- single flag choice. This means that all flag choices are treated--- as interdependent. So if one flag of a package ends up in a--- conflict set, then all flags are being treated as being part of--- the conflict set.-simplifyVar :: Var qpn -> Var qpn-simplifyVar (P qpn)       = P qpn-simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))-simplifyVar (S qsn)       = S qsn--showVar :: Var QPN -> String-showVar (P qpn) = showQPN qpn-showVar (F qfn) = showQFN qfn-showVar (S qsn) = showQSN qsn---- | Extract the package instance from a Var-varPI :: Var QPN -> (QPN, Maybe I)-varPI (P qpn)               = (qpn, Nothing)-varPI (F (FN (PI qpn i) _)) = (qpn, Just i)-varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
− Distribution/Client/Dependency/Modular/Version.hs 
@@ -1,53 +0,0 @@-module Distribution.Client.Dependency.Modular.Version-    ( Ver-    , VR-    , anyVR-    , checkVR-    , eqVR-    , showVer-    , showVR-    , simplifyVR-    , (.&&.)-    , (.||.)-    ) where--import qualified Distribution.Version as CV -- from Cabal-import Distribution.Text -- from Cabal---- | Preliminary type for versions.-type Ver = CV.Version---- | String representation of a version.-showVer :: Ver -> String-showVer = display---- | Version range. Consists of a lower and upper bound.-type VR = CV.VersionRange---- | String representation of a version range.-showVR :: VR -> String-showVR = display---- | 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-(.&&.) = CV.intersectVersionRanges---- | Union of two version ranges.-(.||.) :: VR -> VR -> VR-(.||.) = CV.unionVersionRanges---- | 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/Client/Dependency/TopDown.hs 
@@ -1,1079 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown (-    topDownResolver-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints-import Distribution.Client.Dependency.TopDown.Constraints-         ( Satisfiable(..) )-import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..)-         , enableStanzas, ConfiguredId(..), fakeUnitId )-import Distribution.Client.Dependency.Types-         ( DependencyResolver, ResolverPackage(..)-         , PackageConstraint(..), unlabelPackageConstraint-         , PackagePreferences(..), InstalledPreference(..)-         , Progress(..), foldProgress )--import qualified Distribution.Client.PackageIndex as PackageIndex-import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Client.ComponentDeps-         ( ComponentDeps )-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Package-         ( PackageName(..), PackageId, PackageIdentifier(..)-         , UnitId(..), ComponentId(..)-         , Package(..), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion, simplifyDependency )-import Distribution.PackageDescription-         ( PackageDescription(buildDepends) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription, flattenPackageDescription )-import Distribution.Version-         ( Version(..), VersionRange, withinRange, simplifyVersionRange-         , UpperBound(..), asVersionIntervals )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.System-         ( Platform )-import Distribution.Simple.Utils-         ( equating, comparing )-import Distribution.Text-         ( display )--import Data.List-         ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )-import Data.Maybe-         ( fromJust, fromMaybe, catMaybes )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(mempty) )-#endif-import Control.Monad-         ( guard )-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Control.Exception-         ( assert )---- --------------------------------------------------------------- * Search state types--- --------------------------------------------------------------type Constraints  = Constraints.Constraints-                      InstalledPackageEx UnconfiguredPackage ExclusionReason-type SelectedPackages = PackageIndex SelectedPackage---- --------------------------------------------------------------- * The search tree type--- --------------------------------------------------------------data SearchSpace inherited pkg-   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]-   | Failure Failure---- --------------------------------------------------------------- * Traverse a search tree--- --------------------------------------------------------------explore :: (PackageName -> PackagePreferences)-        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                       SelectablePackage-        -> Progress Log Failure (SelectedPackages, Constraints)--explore _    (Failure failure)       = Fail failure-explore _    (ChoiceNode (s,c,_) []) = Done (s,c)-explore pref (ChoiceNode _ choices)  =-  case [ choice | [choice] <- choices ] of-    ((_, node'):_) -> Step (logInfo node') (explore pref node')-    []             -> Step (logInfo node') (explore pref node')-      where-        choice     = minimumBy (comparing topSortNumber) choices-        pkgname    = packageName . fst . head $ choice-        (_, node') = maximumBy (bestByPref pkgname) choice-  where-    topSortNumber choice = case fst (head choice) of-      InstalledOnly        (InstalledPackageEx  _ i _) -> i-      SourceOnly           (UnconfiguredPackage _ i _ _) -> i-      InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i--    bestByPref pkgname = case packageInstalledPreference of-        PreferLatest    ->-          comparing (\(p,_) -> (               isPreferred p, packageId p))-        PreferInstalled ->-          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))-      where-        isInstalled (SourceOnly _) = False-        isInstalled _              = True-        isPreferred p = length . filter (packageVersion p `withinRange`) $-                        preferredVersions--        (PackagePreferences preferredVersions packageInstalledPreference _)-          = pref pkgname--    logInfo node = Select selected discarded-      where (selected, discarded) = case node of-              Failure    _               -> ([], [])-              ChoiceNode (_,_,changes) _ -> changes---- --------------------------------------------------------------- * Generate a search tree--- --------------------------------------------------------------type ConfigurePackage = PackageIndex SelectablePackage-                     -> SelectablePackage-                     -> Either [Dependency] SelectedPackage---- | (packages selected, packages discarded)-type SelectionChanges = ([SelectedPackage], [PackageId])--searchSpace :: ConfigurePackage-            -> Constraints-            -> SelectedPackages-            -> SelectionChanges-            -> Set PackageName-            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                           SelectablePackage-searchSpace configure constraints selected changes next =-  assert (Set.null (selectedSet `Set.intersection` next)) $-  assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $-  assert (next `Set.isSubsetOf` Constraints.packages constraints) $--  ChoiceNode (selected, constraints, changes)-    [ [ (pkg, select name pkg)-      | pkg <- PackageIndex.lookupPackageName available name ]-    | name <- Set.elems next ]-  where-    available = Constraints.choices constraints--    selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))--    select name pkg = case configure available pkg of-      Left missing -> Failure $ ConfigureFailed pkg-                        [ (dep, Constraints.conflicting constraints dep)-                        | dep <- missing ]-      Right pkg' ->-        case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of-          Left failure       -> Failure failure-          Right (constraints', newDiscarded) ->-            searchSpace configure-              constraints' selected' (newSelected, newDiscarded) next'-        where-          selected' = foldl' (flip PackageIndex.insert) selected newSelected-          newSelected =-            case Constraints.isPaired constraints (packageId pkg) of-              Nothing     -> [pkg']-              Just pkgid' -> [pkg', pkg'']-                where-                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)-                    (PackageIndex.lookupPackageId available pkgid')--          newPkgs   = [ name'-                      | (Dependency name' _, _) <- newDeps-                      , null (PackageIndex.lookupPackageName selected' name') ]-          newDeps   = concatMap packageConstraints newSelected-          next'     = Set.delete name-                    $ foldl' (flip Set.insert) next newPkgs--packageConstraints :: SelectedPackage -> [(Dependency, Bool)]-packageConstraints = either installedConstraints availableConstraints-                   . preferSource-  where-    preferSource (InstalledOnly        pkg) = Left pkg-    preferSource (SourceOnly           pkg) = Right pkg-    preferSource (InstalledAndSource _ pkg) = Right pkg-    installedConstraints (InstalledPackageEx    _ _ deps) =-      [ (thisPackageVersion dep, True)-      | dep <- deps ]-    availableConstraints (SemiConfiguredPackage _ _ _ deps) =-      [ (dep, False) | dep <- deps ]--addDeps :: Constraints -> [PackageName] -> Constraints-addDeps =-  foldr $ \pkgname cs ->-            case Constraints.addTarget pkgname cs of-              Satisfiable cs' () -> cs'-              _                  -> impossible "addDeps unsatisfiable"--constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints-              -> [PackageId]-              -> Either Failure (Constraints, [PackageId])-constrainDeps pkg []         cs discard =-  case addPackageSelectConstraint (packageId pkg) cs of-    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)-    _                        -> impossible "constrainDeps unsatisfiable(1)"-constrainDeps pkg ((dep, installedConstraint):deps) cs discard =-  case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of-    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)-    Unsatisfiable            -> impossible "constrainDeps unsatisfiable(2)"-    ConflictsWith conflicts  ->-      Left (DependencyConflict pkg dep installedConstraint conflicts)---- --------------------------------------------------------------- * The main algorithm--- --------------------------------------------------------------search :: ConfigurePackage-       -> (PackageName -> PackagePreferences)-       -> Constraints-       -> Set PackageName-       -> Progress Log Failure (SelectedPackages, Constraints)-search configure pref constraints =-  explore pref . searchSpace configure constraints mempty ([], [])---- --------------------------------------------------------------- * The top level resolver--- ---------------------------------------------------------------- | The main exported resolver, with string logging and failure types to fit--- the standard 'DependencyResolver' interface.----topDownResolver :: DependencyResolver-topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB-                preferences constraints targets =-    mapMessages $ topDownResolver'-                    platform cinfo-                    (convertInstalledPackageIndex installedPkgIndex)-                    sourcePkgIndex-                    preferences-                    (map unlabelPackageConstraint constraints)-                    targets-  where-    mapMessages :: Progress Log Failure a -> Progress String String a-    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done---- | The native resolver with detailed structured logging and failure types.----topDownResolver' :: Platform -> CompilerInfo-                 -> PackageIndex InstalledPackage-                 -> PackageIndex SourcePackage-                 -> (PackageName -> PackagePreferences)-                 -> [PackageConstraint]-                 -> [PackageName]-                 -> Progress Log Failure [ResolverPackage]-topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex-                 preferences constraints targets =-      fmap (uncurry finalise)-    . (\cs -> search configure preferences cs initialPkgNames)-  =<< pruneBottomUp platform cinfo-  =<< addTopLevelConstraints constraints-  =<< addTopLevelTargets targets emptyConstraintSet--  where-    configure   = configurePackage platform cinfo-    emptyConstraintSet :: Constraints-    emptyConstraintSet = Constraints.empty-      (annotateInstalledPackages          topSortNumber installedPkgIndex')-      (annotateSourcePackages constraints topSortNumber sourcePkgIndex')-    (installedPkgIndex', sourcePkgIndex') =-      selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames-    topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'--    initialPkgNames = Set.fromList targets--    finalise selected' constraints' =-        map toResolverPackage-      . PackageIndex.allPackages-      . fst . improvePlan installedPkgIndex' constraints'-      . PackageIndex.fromList-      $ finaliseSelectedPackages preferences selected' constraints'--    toResolverPackage :: FinalSelectedPackage -> ResolverPackage-    toResolverPackage (SelectedInstalled (InstalledPackage pkg _))-                                              = PreExisting pkg-    toResolverPackage (SelectedSource    pkg) = Configured  pkg--addTopLevelTargets :: [PackageName]-                   -> Constraints-                   -> Progress a Failure Constraints-addTopLevelTargets []         cs = Done cs-addTopLevelTargets (pkg:pkgs) cs =-  case Constraints.addTarget pkg cs of-    Satisfiable cs' ()       -> addTopLevelTargets pkgs cs'-    Unsatisfiable            -> Fail (NoSuchPackage pkg)-    ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"---addTopLevelConstraints :: [PackageConstraint] -> Constraints-                       -> Progress Log Failure Constraints-addTopLevelConstraints []                                      cs = Done cs-addTopLevelConstraints (PackageConstraintFlags   _   _  :deps) cs =-  addTopLevelConstraints deps cs--addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =-  case addTopLevelVersionConstraint pkg ver cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedVersionConstraint pkg ver pkgids)-           (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)--    ConflictsWith conflicts ->-      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)--addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =-  case addTopLevelInstalledConstraint pkg cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)-           (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)--    ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts)--addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =-  case addTopLevelSourceConstraint pkg cs of-    Satisfiable cs' pkgids  ->-      Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)-            (addTopLevelConstraints deps cs')--    Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)--    ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)--addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =-    addTopLevelConstraints deps cs---- | Add exclusion on available packages that cannot be configured.----pruneBottomUp :: Platform -> CompilerInfo-              -> Constraints -> Progress Log Failure Constraints-pruneBottomUp platform comp constraints =-    foldr prune Done (initialPackages constraints) constraints--  where-    prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs-      where-        unconfigurable =-          [ (pkg, missing) -- if necessary we could look up missing reasons-          | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs-          , Left missing <- [configure cs pkg'] ]--    addExcludeConstraint (pkg, missing) rest cs =-      let reason = ExcludedByConfigureFail missing in-      case addPackageExcludeConstraint (packageId pkg) reason cs of-        Satisfiable cs' [pkgid]| packageId pkg == pkgid-                         -> Step (ExcludeUnconfigurable pkgid) (rest cs')-        Satisfiable _ _  -> impossible "pruneBottomUp satisfiable"-        _                -> Fail $ ConfigureFailed pkg-                              [ (dep, Constraints.conflicting cs dep)-                              | dep <- missing ]--    configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) =-      finalizePackageDescription flags (dependencySatisfiable cs)-                                 platform comp [] (enableStanzas stanzas pkg)-    dependencySatisfiable cs =-      not . null . PackageIndex.lookupDependency (Constraints.choices cs)--    -- collect each group of packages (by name) in reverse topsort order-    initialPackages =-        reverse-      . sortBy (comparing (topSortNumber . head))-      . PackageIndex.allPackagesByName-      . Constraints.choices--    topSortNumber (InstalledOnly        (InstalledPackageEx  _ i _)) = i-    topSortNumber (SourceOnly           (UnconfiguredPackage _ i _ _)) = i-    topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i--    getSourcePkg (InstalledOnly      _     ) = Nothing-    getSourcePkg (SourceOnly           spkg) = Just spkg-    getSourcePkg (InstalledAndSource _ spkg) = Just spkg---configurePackage :: Platform -> CompilerInfo -> ConfigurePackage-configurePackage platform cinfo available spkg = case spkg of-  InstalledOnly      ipkg      -> Right (InstalledOnly ipkg)-  SourceOnly              apkg -> fmap SourceOnly (configure apkg)-  InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)-                                       (configure apkg)-  where-  configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) =-    case finalizePackageDescription flags dependencySatisfiable-                                    platform cinfo []-                                    (enableStanzas stanzas p) of-      Left missing        -> Left missing-      Right (pkg, flags') -> Right $-        SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)--  dependencySatisfiable = not . null . PackageIndex.lookupDependency available---- | Annotate each installed packages with its set of transitive dependencies--- and its topological sort number.----annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)-                          -> PackageIndex InstalledPackage-                          -> PackageIndex InstalledPackageEx-annotateInstalledPackages dfsNumber installed = PackageIndex.fromList-  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)-  | pkg <- PackageIndex.allPackages installed ]-  where-    transitiveDepends :: InstalledPackage -> [PackageId]-    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph-                      . fromJust . toVertex . packageId-    (graph, toPkg, toVertex) = dependencyGraph installed----- | Annotate each available packages with its topological sort number and any--- user-supplied partial flag assignment.----annotateSourcePackages :: [PackageConstraint]-                       -> (PackageName -> TopologicalSortNumber)-                       -> PackageIndex SourcePackage-                       -> PackageIndex UnconfiguredPackage-annotateSourcePackages constraints dfsNumber sourcePkgIndex =-    PackageIndex.fromList-      [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)-      | pkg <- PackageIndex.allPackages sourcePkgIndex-      , let name = packageName pkg ]-  where-    flagsFor = fromMaybe [] . flip Map.lookup flagsMap-    flagsMap = Map.fromList-      [ (name, flags)-      | PackageConstraintFlags name flags <- constraints ]-    stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap-    stanzasMap = Map.fromListWith (++)-        [ (name, stanzas)-        | PackageConstraintStanzas name stanzas <- constraints ]---- | One of the heuristics we use when guessing which path to take in the--- search space is an ordering on the choices we make. It's generally better--- to make decisions about packages higer in the dep graph first since they--- place constraints on packages lower in the dep graph.------ To pick them in that order we annotate each package with its topological--- sort number. So if package A depends on package B then package A will have--- a lower topological sort number than B and we'll make a choice about which--- version of A to pick before we make a choice about B (unless there is only--- one possible choice for B in which case we pick that immediately).------ To construct these topological sort numbers we combine and flatten the--- installed and source package sets. We consider only dependencies between--- named packages, not including versions and for not-yet-configured packages--- we look at all the possible dependencies, not just those under any single--- flag assignment. This means we can actually get impossible combinations of--- edges and even cycles, but that doesn't really matter here, it's only a--- heuristic.----topologicalSortNumbering :: PackageIndex InstalledPackage-                         -> PackageIndex SourcePackage-                         -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installedPkgIndex sourcePkgIndex =-    \pkgname -> let Just vertex = toVertex pkgname-                 in topologicalSortNumbers Array.! vertex-  where-    topologicalSortNumbers = Array.array (Array.bounds graph)-                                         (zip (Graph.topSort graph) [0..])-    (graph, _, toVertex)   = Graph.graphFromEdges $-         [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex-         , let deps = [ packageName dep-                      | pkg' <- pkgs-                      , dep  <- sourceDeps pkg' ] ]-      ++ [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex-         , let deps = [ depName-                      | SourcePackage _ pkg' _ _ <- pkgs-                      , Dependency depName _ <--                          buildDepends (flattenPackageDescription pkg') ] ]---- | We don't need the entire index (which is rather large and costly if we--- force it by examining the whole thing). So trace out the maximul subset of--- each index that we could possibly ever need. Do this by flattening packages--- and looking at the names of all possible dependencies.----selectNeededSubset :: PackageIndex InstalledPackage-                   -> PackageIndex SourcePackage-                   -> Set PackageName-                   -> (PackageIndex InstalledPackage-                      ,PackageIndex SourcePackage)-selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty-  where-    select :: PackageIndex InstalledPackage-           -> PackageIndex SourcePackage-           -> Set PackageName-           -> (PackageIndex InstalledPackage-              ,PackageIndex SourcePackage)-    select installedPkgIndex' sourcePkgIndex' remaining-      | Set.null remaining = (installedPkgIndex', sourcePkgIndex')-      | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''-      where-        (next, remaining') = Set.deleteFindMin remaining-        moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next-        moreSource    = PackageIndex.lookupPackageName sourcePkgIndex next-        moreRemaining = -- we filter out packages already included in the indexes-                        -- this avoids an infinite loop if a package depends on itself-                        -- like base-3.0.3.0 with base-4.0.0.0-                        filter notAlreadyIncluded-                      $ [ packageName dep-                        | pkg <- moreInstalled-                        , dep <- sourceDeps pkg ]-                     ++ [ name-                        | SourcePackage _ pkg _ _ <- moreSource-                        , Dependency name _ <--                            buildDepends (flattenPackageDescription pkg) ]-        installedPkgIndex'' = foldl' (flip PackageIndex.insert)-                                     installedPkgIndex' moreInstalled-        sourcePkgIndex''    = foldl' (flip PackageIndex.insert)-                                     sourcePkgIndex' moreSource-        remaining''         = foldl' (flip          Set.insert)-                                     remaining' moreRemaining-        notAlreadyIncluded name =-            null (PackageIndex.lookupPackageName installedPkgIndex' name)-         && null (PackageIndex.lookupPackageName sourcePkgIndex' name)----- | The old top down solver assumes that installed packages are indexed by--- their source package id. But these days they're actually indexed by an--- installed package id and there can be many installed packages with the same--- source package id. This function tries to do a convertion, but it can only--- be partial.----convertInstalledPackageIndex :: InstalledPackageIndex-                             -> PackageIndex InstalledPackage-convertInstalledPackageIndex index' = PackageIndex.fromList-    -- There can be multiple installed instances of each package version,-    -- like when the same package is installed in the global & user DBs.-    -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the-    -- installed packages with the most preferred instances first, so by-    -- picking the first we should get the user one. This is almost but not-    -- quite the same as what ghc does.-    [ InstalledPackage ipkg (sourceDepsOf index' ipkg)-    | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]-  where-    -- The InstalledPackageInfo only lists dependencies by the-    -- UnitId, which means we do not directly know the corresponding-    -- source dependency. The only way to find out is to lookup the-    -- UnitId to get the InstalledPackageInfo and look at its-    -- source PackageId. But if the package is broken because it depends on-    -- other packages that do not exist then we have a problem we cannot find-    -- the original source package id. Instead we make up a bogus package id.-    -- This should have the same effect since it should be a dependency on a-    -- nonexistent package.-    sourceDepsOf index ipkg =-      [ maybe (brokenPackageId depid) packageId mdep-      | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupUnitId index-      , (depid, mdep) <- zip depids (map getpkg depids) ]--    brokenPackageId (SimpleUnitId (ComponentId str)) =-      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])---- --------------------------------------------------------------- * Post processing the solution--- --------------------------------------------------------------finaliseSelectedPackages :: (PackageName -> PackagePreferences)-                         -> SelectedPackages-                         -> Constraints-                         -> [FinalSelectedPackage]-finaliseSelectedPackages pref selected constraints =-  map finaliseSelected (PackageIndex.allPackages selected)-  where-    remainingChoices = Constraints.choices constraints-    finaliseSelected (InstalledOnly      ipkg     ) = finaliseInstalled ipkg-    finaliseSelected (SourceOnly              apkg) = finaliseSource Nothing apkg-    finaliseSelected (InstalledAndSource ipkg apkg) =-      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of-                                        --picked package not in constraints-        Nothing                       -> impossible "finaliseSelected no pkg"-                                        -- to constrain to avail only:-        Just (SourceOnly _)           -> impossible "finaliseSelected src only"-        Just (InstalledOnly _)        -> finaliseInstalled ipkg-        Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg--    finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg-    finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =-        SelectedSource (ConfiguredPackage pkg flags stanzas deps')-      where-        -- We cheat in the cabal solver, and classify all dependencies as-        -- library dependencies.-        deps' :: ComponentDeps [ConfiguredId]-        deps' = CD.fromLibraryDeps $ map (confId . pickRemaining mipkg) deps--    -- InstalledOrSource indicates that we either have a source package-    -- available, or an installed one, or both. In the case that we have both-    -- available, we don't yet know if we can pick the installed one (the-    -- dependencies may not match up, for instance); this is verified in-    -- `improvePlan`.-    ---    -- This means that at this point we cannot construct a valid installed-    -- package ID yet for the dependencies. We therefore have two options:-    ---    -- * We could leave the installed package ID undefined here, and have a-    --   separate pass over the output of the top-down solver, fixing all-    --   dependencies so that if we depend on an already installed package we-    --   use the proper installed package ID.-    ---    -- * We can _always_ use fake installed IDs, irrespective of whether we the-    --   dependency is on an already installed package or not. This is okay-    --   because (i) the top-down solver does not (and never will) support-    --   multiple package instances, and (ii) we initialize the FakeMap with-    --   fake IDs for already installed packages.-    ---    -- For now we use the second option; if however we change the implementation-    -- of these fake IDs so that we do away with the FakeMap and update a-    -- package reverse dependencies as we execute the install plan and discover-    -- real package IDs, then this is no longer possible and we have to-    -- implement the first option (see also Note [FakeMap] in Cabal).-    confId :: InstalledOrSource InstalledPackageEx UnconfiguredPackage -> ConfiguredId-    confId pkg = ConfiguredId {-        confSrcId  = packageId pkg-      , confInstId = fakeUnitId (packageId pkg)-      }--    pickRemaining mipkg dep@(Dependency _name versionRange) =-          case PackageIndex.lookupDependency remainingChoices dep of-            []        -> impossible "pickRemaining no pkg"-            [pkg']    -> pkg'-            remaining -> assert (checkIsPaired remaining)-                       $ maximumBy bestByPref remaining-      where-        -- We order candidate packages to pick for a dependency by these-        -- three factors. The last factor is just highest version wins.-        bestByPref =-          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))-        -- Is the package already used by the installed version of this-        -- package? If so we should pick that first. This stops us from doing-        -- silly things like deciding to rebuild haskell98 against base 3.-        isCurrent = case mipkg :: Maybe InstalledPackageEx of-          Nothing   -> \_ -> False-          Just ipkg -> \p -> packageId p `elem` sourceDeps ipkg-        -- If there is no upper bound on the version range then we apply a-        -- preferred version according to the hackage or user's suggested-        -- version constraints. TODO: distinguish hacks from prefs-        bounded = boundedAbove versionRange-        isPreferred p-          | bounded   = boundedRank -- this is a dummy constant-          | otherwise = length . filter (packageVersion p `withinRange`) $-                        preferredVersions-          where (PackagePreferences preferredVersions _ _) = pref (packageName p)-        boundedRank = 0 -- any value will do--        boundedAbove :: VersionRange -> Bool-        boundedAbove vr = case asVersionIntervals vr of-          []        -> True -- this is the inconsistent version range.-          intervals -> case last intervals of-            (_,   UpperBound _ _) -> True-            (_, NoUpperBound    ) -> False--        -- We really only expect to find more than one choice remaining when-        -- we're finalising a dependency on a paired package.-        checkIsPaired [p1, p2] =-          case Constraints.isPaired constraints (packageId p1) of-            Just p2'   -> packageId p2' == packageId p2-            Nothing    -> False-        checkIsPaired _ = False---- | Improve an existing installation plan by, where possible, swapping--- packages we plan to install with ones that are already installed.--- This may add additional constraints due to the dependencies of installed--- packages on other installed packages.----improvePlan :: PackageIndex InstalledPackage-            -> Constraints-            -> PackageIndex FinalSelectedPackage-            -> (PackageIndex FinalSelectedPackage, Constraints)-improvePlan installed constraints0 selected0 =-  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)-  where-    improve (selected, constraints) = fromMaybe (selected, constraints)-                                    . improvePkg selected constraints--    -- The idea is to improve the plan by swapping a configured package for-    -- an equivalent installed one. For a particular package the condition is-    -- that the package be in a configured state, that a the same version be-    -- already installed with the exact same dependencies and all the packages-    -- in the plan that it depends on are in the installed state-    improvePkg selected constraints pkgid = do-      SelectedSource pkg  <- PackageIndex.lookupPackageId selected  pkgid-      ipkg                <- PackageIndex.lookupPackageId installed pkgid-      guard $ all (isInstalled selected) (sourceDeps pkg)-      tryInstalled selected constraints [ipkg]--    isInstalled selected pkgid =-      case PackageIndex.lookupPackageId selected pkgid of-        Just (SelectedInstalled _) -> True-        _                          -> False--    tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints-                 -> [InstalledPackage]-                 -> Maybe (PackageIndex FinalSelectedPackage, Constraints)-    tryInstalled selected constraints [] = Just (selected, constraints)-    tryInstalled selected constraints (pkg:pkgs) =-      case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of-        Nothing           -> Nothing-        Just constraints' -> tryInstalled selected' constraints' pkgs'-          where-            selected' = PackageIndex.insert (SelectedInstalled pkg) selected-            pkgs'      = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs-            notSelected pkgid =-              case (PackageIndex.lookupPackageId installed pkgid-                   ,PackageIndex.lookupPackageId selected  pkgid) of-                (Just pkg', Nothing) -> Just pkg'-                _                    -> Nothing--    constraintsOk _     []              constraints = Just constraints-    constraintsOk pkgid (pkgid':pkgids) constraints =-      case addPackageDependencyConstraint pkgid dep True constraints of-        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'-        _                          -> Nothing-      where-        dep = thisPackageVersion pkgid'--    reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId]-    reverseTopologicalOrder index = map (packageId . toPkg)-                                  . Graph.topSort-                                  . Graph.transposeG-                                  $ graph-      where (graph, toPkg, _) = dependencyGraph index---- --------------------------------------------------------------- * Adding and recording constraints--- --------------------------------------------------------------addPackageSelectConstraint :: PackageId -> Constraints-                           -> Satisfiable Constraints-                                [PackageId] ExclusionReason-addPackageSelectConstraint pkgid =-    Constraints.constrain pkgname constraint reason-  where-    pkgname          = packageName pkgid-    constraint ver _ = ver == packageVersion pkgid-    reason           = SelectedOther pkgid--addPackageExcludeConstraint :: PackageId -> ExclusionReason-                            -> Constraints-                            -> Satisfiable Constraints-                                           [PackageId] ExclusionReason-addPackageExcludeConstraint pkgid reason =-    Constraints.constrain pkgname constraint reason-  where-    pkgname = packageName pkgid-    constraint ver installed-      | ver == packageVersion pkgid = installed-      | otherwise                   = True--addPackageDependencyConstraint :: PackageId -> Dependency -> Bool-                               -> Constraints-                               -> Satisfiable Constraints-                                    [PackageId] ExclusionReason-addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)-                                     installedConstraint =-    Constraints.constrain pkgname constraint reason-  where-    constraint ver installed = ver `withinRange` verrange-                            && if installedConstraint then installed else True-    reason = ExcludedByPackageDependency pkgid dep installedConstraint--addTopLevelVersionConstraint :: PackageName -> VersionRange-                             -> Constraints-                             -> Satisfiable Constraints-                                  [PackageId] ExclusionReason-addTopLevelVersionConstraint pkgname verrange =-    Constraints.constrain pkgname constraint reason-  where-    constraint ver _installed = ver `withinRange` verrange-    reason = ExcludedByTopLevelConstraintVersion pkgname verrange--addTopLevelInstalledConstraint,-  addTopLevelSourceConstraint :: PackageName-                              -> Constraints-                              -> Satisfiable Constraints-                                   [PackageId] ExclusionReason-addTopLevelInstalledConstraint pkgname =-    Constraints.constrain pkgname constraint reason-  where-    constraint _ver installed = installed-    reason = ExcludedByTopLevelConstraintInstalled pkgname--addTopLevelSourceConstraint pkgname =-    Constraints.constrain pkgname constraint reason-  where-    constraint _ver installed = not installed-    reason = ExcludedByTopLevelConstraintSource pkgname----- --------------------------------------------------------------- * Reasons for constraints--- ---------------------------------------------------------------- | For every constraint we record we also record the reason that constraint--- is needed. So if we end up failing due to conflicting constraints then we--- can give an explnanation as to what was conflicting and why.----data ExclusionReason =--     -- | We selected this other version of the package. That means we exclude-     -- all the other versions.-     SelectedOther PackageId--     -- | We excluded this version of the package because it failed to-     -- configure probably because of unsatisfiable deps.-   | ExcludedByConfigureFail [Dependency]--     -- | We excluded this version of the package because another package that-     -- we selected imposed a dependency which this package did not satisfy.-   | ExcludedByPackageDependency PackageId Dependency Bool--     -- | We excluded this version of the package because it did not satisfy-     -- a dependency given as an original top level input.-     ---   | ExcludedByTopLevelConstraintVersion   PackageName VersionRange-   | ExcludedByTopLevelConstraintInstalled PackageName-   | ExcludedByTopLevelConstraintSource    PackageName--  deriving Eq---- | Given an excluded package and the reason it was excluded, produce a human--- readable explanation.----showExclusionReason :: PackageId -> ExclusionReason -> String-showExclusionReason pkgid (SelectedOther pkgid') =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " was selected instead"-showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =-  display pkgid ++ " was excluded because it could not be configured. "-  ++ "It requires " ++ listOf displayDep missingDeps-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)-  = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "- ++ (if installedConstraint then "an installed instance of " else "")- ++ displayDep dep-showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =-  display pkgid ++ " was excluded because of the top level constraint " ++-  displayDep (Dependency pkgname verRange)-showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)-  = display pkgid ++ " was excluded because of the top level constraint '"- ++ display pkgname ++ " installed' which means that only installed instances "- ++ "of the package may be selected."-showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)-  = display pkgid ++ " was excluded because of the top level constraint '"- ++ display pkgname ++ " source' which means that only source versions "- ++ "of the package may be selected."----- --------------------------------------------------------------- * Logging progress and failures--- --------------------------------------------------------------data Log = Select [SelectedPackage] [PackageId]-         | AppliedVersionConstraint   PackageName VersionRange [PackageId]-         | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]-         | ExcludeUnconfigurable PackageId--data Failure-   = NoSuchPackage-       PackageName-   | ConfigureFailed-       SelectablePackage-       [(Dependency, [(PackageId, [ExclusionReason])])]-   | DependencyConflict-       SelectedPackage Dependency Bool-       [(PackageId, [ExclusionReason])]-   | TopLevelVersionConstraintConflict-       PackageName VersionRange-       [(PackageId, [ExclusionReason])]-   | TopLevelVersionConstraintUnsatisfiable-       PackageName VersionRange-   | TopLevelInstallConstraintConflict-       PackageName InstalledConstraint-       [(PackageId, [ExclusionReason])]-   | TopLevelInstallConstraintUnsatisfiable-       PackageName InstalledConstraint--showLog :: Log -> String-showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of-  ("", y) -> y-  (x, "") -> x-  (x,  y) -> x ++ " and " ++ y--  where-    selectedMsg  = "selecting " ++ case selected of-      []     -> ""-      [s]    -> display (packageId s) ++ " " ++ kind s-      (s:ss) -> listOf id-              $ (display (packageId s) ++ " " ++ kind s)-              : [ display (packageVersion s') ++ " " ++ kind s'-                | s' <- ss ]--    kind (InstalledOnly _)        = "(installed)"-    kind (SourceOnly _)           = "(source)"-    kind (InstalledAndSource _ _) = "(installed or source)"--    discardedMsg = case discarded of-      []  -> ""-      _   -> "discarding " ++ listOf id-        [ element-        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)-        , element <- display pkgid : map (display . packageVersion) pkgids ]-showLog (AppliedVersionConstraint pkgname ver pkgids) =-     "applying constraint " ++ display (Dependency pkgname ver)-  ++ if null pkgids-       then ""-       else " which excludes " ++ listOf display pkgids-showLog (AppliedInstalledConstraint pkgname inst pkgids) =-     "applying constraint " ++ display pkgname ++ " '"-  ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "-  ++ if null pkgids-       then ""-       else "which excludes " ++ listOf display pkgids-showLog (ExcludeUnconfigurable pkgid) =-     "excluding " ++ display pkgid ++ " (it cannot be configured)"--showFailure :: Failure -> String-showFailure (NoSuchPackage pkgname) =-     "The package " ++ display pkgname ++ " is unknown."-showFailure (ConfigureFailed pkg missingDeps) =-     "cannot configure " ++ displayPkg pkg ++ ". It requires "-  ++ listOf (displayDep . fst) missingDeps-  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)--  where-    whyNot (Dependency name ver) [] =-         "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--    whyNot dep conflicts =-         "For the dependency on " ++ displayDep dep-      ++ " there are these packages: " ++ listOf display pkgs-      ++ ". However none of them are available.\n"-      ++ unlines [ showExclusionReason (packageId pkg') reason-                 | (pkg', reasons) <- conflicts, reason <- reasons ]--      where pkgs = map fst conflicts--showFailure (DependencyConflict pkg dep installedConstraint conflicts) =-     "dependencies conflict: "-  ++ displayPkg pkg ++ " requires "-  ++ (if installedConstraint then "an installed instance of " else "")-  ++ displayDep dep ++ " however:\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintConflict name ver conflicts) =-     "constraints conflict: we have the top level constraint "-  ++ displayDep (Dependency name ver) ++ ", but\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =-     "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =-     "constraints conflict: "-  ++ "top level constraint '" ++ display name ++ " installed' however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =-     "There is no installed version of " ++ display name--showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =-     "constraints conflict: "-  ++ "top level constraint '" ++ display name ++ " source' however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =-     "There is no available source version of " ++ display name--displayVer :: VersionRange -> String-displayVer = display . simplifyVersionRange--displayDep :: Dependency -> String-displayDep = display . simplifyDependency----- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------impossible :: String -> a-impossible msg = internalError $ "assertion failure: " ++ msg--internalError :: String -> a-internalError msg = error $ "internal error: " ++ msg--displayPkg :: Package pkg => pkg -> String-displayPkg = display . packageId--listOf :: (a -> String) -> [a] -> String-listOf _    []   = []-listOf disp [x0] = disp x0-listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs-  where go x []       = " and " ++ disp x-        go x (x':xs') = ", " ++ disp x ++ go x' xs'---- --------------------------------------------------------------- * Construct a dependency graph--- ---------------------------------------------------------------- | Builds a graph of the package dependencies.------ Dependencies on other packages that are not in the index are discarded.--- You can check if there are any such dependencies with 'brokenPackages'.------ The top-down solver gets its own implementation, because both--- `dependencyGraph` in `Distribution.Client.PlanIndex` (in cabal-install) and--- `dependencyGraph` in `Distribution.Simple.PackageIndex` (in Cabal) both work--- with `PackageIndex` from `Cabal` (that is, a package index indexed by--- installed package IDs rather than package names).------ Ideally we would switch the top-down solver over to use that too, so that--- this duplication could be avoided, but that's a bit of work and the top-down--- solver is legacy code anyway.------ (NOTE: This is called at two types: InstalledPackage and FinalSelectedPackage.)-dependencyGraph :: PackageSourceDeps pkg-                => PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    PackageId -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)-  where-    graph = Array.listArray bounds $-            map (catMaybes . map pkgIdToVertex . sourceDeps) pkgs-    vertexToPkg vertex = pkgTable Array.! vertex-    pkgIdToVertex = binarySearch 0 topBound--    pkgTable   = Array.listArray bounds pkgs-    pkgIdTable = Array.listArray bounds (map packageId pkgs)-    pkgs = sortBy (comparing packageId) (PackageIndex.allPackages index)-    topBound = length pkgs - 1-    bounds = (0, topBound)--    binarySearch a b key-      | a > b     = Nothing-      | otherwise = case compare key (pkgIdTable Array.! mid) of-          LT -> binarySearch a (mid-1) key-          EQ -> Just mid-          GT -> binarySearch (mid+1) b key-      where mid = (a + b) `div` 2
− Distribution/Client/Dependency/TopDown/Constraints.hs 
@@ -1,599 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Constraints--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ A set of satisfiable constraints on a set of packages.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown.Constraints (-  Constraints,-  empty,-  packages,-  choices,-  isPaired,--  addTarget,-  constrain,-  Satisfiable(..),-  conflicting,-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex-        ( PackageIndex )-import Distribution.Package-         ( PackageName, PackageId, PackageIdentifier(..)-         , Package(packageId), packageName, packageVersion-         , Dependency )-import Distribution.Version-         ( Version )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(mempty) )-#endif-import Data.Either-         ( partitionEithers )-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import Data.Set (Set)-import Control.Exception-         ( assert )----- | A set of satisfiable constraints on a set of packages.------ The 'Constraints' type keeps track of a set of targets (identified by--- package name) that we know that we need. It also keeps track of a set of--- constraints over all packages in the environment.------ It maintains the guarantee that, for the target set, the constraints are--- satisfiable, meaning that there is at least one instance available for each--- package name that satisfies the constraints on that package name.------ Note that it is possible to over-constrain a package in the environment that--- is not in the target set -- the satisfiability guarantee is only maintained--- for the target set. This is useful because it allows us to exclude packages--- without needing to know if it would ever be needed or not (e.g. allows--- excluding broken installed packages).------ Adding a constraint for a target package can fail if it would mean that--- there are no remaining choices.------ Adding a constraint for package that is not a target never fails.------ Adding a new target package can fail if that package already has conflicting--- constraints.----data Constraints installed source reason-   = Constraints--       -- | Targets that we know we need. This is the set for which we-       -- guarantee the constraints are satisfiable.-       !(Set PackageName)--       -- | The available/remaining set. These are packages that have available-       -- choices remaining. This is guaranteed to cover the target packages,-       -- but can also cover other packages in the environment. New targets can-       -- only be added if there are available choices remaining for them.-       !(PackageIndex (InstalledOrSource installed source))--       -- | The excluded set. Choices that we have excluded by applying-       -- constraints. Excluded choices are tagged with the reason.-       !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason))--       -- | Paired choices, this is an ugly hack.-       !(Map PackageName (Version, Version))--       -- | Purely for the invariant, we keep a copy of the original index-       !(PackageIndex (InstalledOrSource installed source))----- | Reasons for excluding all, or some choices for a package version.------ Each package version can have a source instance, an installed instance or--- both. We distinguish reasons for constraints that excluded both instances,--- from reasons for constraints that excluded just one instance.----data ExcludedPkg pkg reason-   = ExcludedPkg pkg-       [reason] -- ^ reasons for excluding both source and installed instances-       [reason] -- ^ reasons for excluding the installed instance-       [reason] -- ^ reasons for excluding the source instance--instance Package pkg => Package (ExcludedPkg pkg reason) where-  packageId (ExcludedPkg p _ _ _) = packageId p----- | There is a conservation of packages property. Packages are never gained or--- lost, they just transfer from the remaining set to the excluded set.----invariant :: (Package installed, Package source)-          => Constraints installed source a -> Bool-invariant (Constraints targets available excluded _ original) =--    -- Relationship between available, excluded and original-    all check merged--    -- targets is a subset of available- && all (PackageIndex.elemByPackageName available) (Set.elems targets)--  where-    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)-                     (PackageIndex.allPackages original)-                     (mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages available)-                              (PackageIndex.allPackages excluded))-      where-        mergedPackageId (OnlyInLeft  p  ) = packageId p-        mergedPackageId (OnlyInRight   p) = packageId p-        mergedPackageId (InBoth      p _) = packageId p--    -- If the package was originally installed only, then-    check (InBoth (InstalledOnly _) cur) = case cur of-      -- now it's either still remaining as installed only-      OnlyInLeft               (InstalledOnly _)              -> True-      -- or it has been excluded-      OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True-      _                                                       -> False--    -- If the package was originally available only, then-    check (InBoth (SourceOnly _) cur) = case cur of-      -- now it's either still remaining as source only-      OnlyInLeft               (SourceOnly _)              -> True-      -- or it has been excluded-      OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True-      _                                                    -> False--    -- If the package was originally installed and source, then-    check (InBoth (InstalledAndSource _ _) cur) = case cur of-      -- We can have both remaining:-      OnlyInLeft               (InstalledAndSource _ _)        -> True--      -- both excluded, in particular it can have had the just source or-      -- installed excluded and later had both excluded so we do not mind if-      -- the source or installed excluded is empty or non-empty.-      OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True--      -- the installed remaining and the source excluded:-      InBoth                   (InstalledOnly _)-                  (ExcludedPkg (SourceOnly _) [] [] (_:_))     -> True--      -- the source remaining and the installed excluded:-      InBoth                   (SourceOnly _)-                  (ExcludedPkg (InstalledOnly _) [] (_:_) [])  -> True-      _                                                        -> False--    check _ = False----- | An update to the constraints can move packages between the two piles--- but not gain or loose packages.-transitionsTo :: (Package installed, Package source)-              => Constraints installed source a-              -> Constraints installed source a -> Bool-transitionsTo constraints @(Constraints _ available  excluded  _ _)-              constraints'@(Constraints _ available' excluded' _ _) =--     invariant constraints && invariant constraints'-  && null availableGained  && null excludedLost-  &&    map (mapInstalledOrSource packageId packageId) availableLost-     == map (mapInstalledOrSource packageId packageId) excludedGained--  where-    (availableLost, availableGained)-      = partitionEithers (foldr lostAndGained [] availableChange)--    (excludedLost, excludedGained)-      = partitionEithers (foldr lostAndGained [] excludedChange)--    availableChange =-      mergeBy (\a b -> packageId a `compare` packageId b)-        (PackageIndex.allPackages available)-        (PackageIndex.allPackages available')--    excludedChange =-      mergeBy (\a b -> packageId a `compare` packageId b)-        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded  ]-        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]--    lostAndGained mr rest = case mr of-      OnlyInLeft pkg                    -> Left pkg : rest-      InBoth (InstalledAndSource pkg _)-             (SourceOnly _)             -> Left (InstalledOnly pkg) : rest-      InBoth (InstalledAndSource _ pkg)-             (InstalledOnly _)          -> Left (SourceOnly pkg) : rest-      InBoth (SourceOnly _)-             (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest-      InBoth (InstalledOnly _)-             (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest-      OnlyInRight pkg                   -> Right pkg : rest-      _                                 -> rest--    mapInstalledOrSource f g pkg = case pkg of-      InstalledOnly      a   -> InstalledOnly (f a)-      SourceOnly           b -> SourceOnly    (g b)-      InstalledAndSource a b -> InstalledAndSource (f a) (g b)---- | We construct 'Constraints' with an initial 'PackageIndex' of all the--- packages available.----empty :: PackageIndex InstalledPackageEx-      -> PackageIndex UnconfiguredPackage-      -> Constraints InstalledPackageEx UnconfiguredPackage reason-empty installed source =-    Constraints targets pkgs excluded pairs pkgs-  where-    targets  = mempty-    excluded = mempty-    pkgs = PackageIndex.fromList-         . map toInstalledOrSource-         $ mergeBy (\a b -> packageId a `compare` packageId b)-                   (PackageIndex.allPackages installed)-                   (PackageIndex.allPackages source)-    toInstalledOrSource (OnlyInLeft  i  ) = InstalledOnly      i-    toInstalledOrSource (OnlyInRight   a) = SourceOnly           a-    toInstalledOrSource (InBoth      i a) = InstalledAndSource i a--    -- pick up cases like base-3 and 4 where one version depends on the other:-    pairs = Map.fromList-      [ (name, (packageVersion pkgid1, packageVersion pkgid2))-      | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed-      , let name   = packageName pkg1-            pkgid1 = packageId pkg1-            pkgid2 = packageId pkg2-      ,    any ((pkgid1==) . packageId) (sourceDeps pkg2)-        || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]----- | The package targets.----packages :: Constraints installed source reason-         -> Set PackageName-packages (Constraints ts _ _ _ _) = ts----- | The package choices that are still available.----choices :: Constraints installed source reason-        -> PackageIndex (InstalledOrSource installed source)-choices (Constraints _ available _ _ _) = available--isPaired :: Constraints installed source reason-         -> PackageId -> Maybe PackageId-isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =-  case Map.lookup name pairs of-    Just (v1, v2)-      | version == v1 -> Just (PackageIdentifier name v2)-      | version == v2 -> Just (PackageIdentifier name v1)-    _                 -> Nothing---data Satisfiable constraints discarded reason-       = Satisfiable constraints discarded-       | Unsatisfiable-       | ConflictsWith [(PackageId, [reason])]---addTarget :: (Package installed, Package source)-          => PackageName-          -> Constraints installed source reason-          -> Satisfiable (Constraints installed source reason)-                         () reason-addTarget pkgname-          constraints@(Constraints targets available excluded paired original)--    -- If it's already a target then there's no change-  | pkgname `Set.member` targets-  = Satisfiable constraints ()--    -- If there is some possible choice available for this target then we're ok-  | PackageIndex.elemByPackageName available pkgname-  = let targets'     = Set.insert pkgname targets-        constraints' = Constraints targets' available excluded paired original-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints' ()--    -- If it's not available and it is excluded then we return the conflicts-  | PackageIndex.elemByPackageName excluded pkgname-  = ConflictsWith conflicts--    -- Otherwise, it's not available and it has not been excluded so the-    -- package is simply completely unknown.-  | otherwise-  = Unsatisfiable--  where-    conflicts =-      [ (packageId pkg, reasons)-      | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname-      , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices-      , let reasons = isReasons ++ iReasons ++ sReasons ]---constrain :: (Package installed, Package source)-          => PackageName                -- ^ which package to constrain-          -> (Version -> Bool -> Bool)  -- ^ the constraint test-          -> reason                     -- ^ the reason for the constraint-          -> Constraints installed source reason-          -> Satisfiable (Constraints installed source reason)-                         [PackageId] reason-constrain pkgname constraint reason-          constraints@(Constraints targets available excluded paired original)--  | pkgname `Set.member` targets  &&  not anyRemaining-  = if null conflicts then Unsatisfiable-                      else ConflictsWith conflicts--  | otherwise-  = let constraints' = Constraints targets available' excluded' paired original-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints' (map packageId newExcluded)--  where-    -- This tells us if any packages would remain at all for this package name if-    -- we applied this constraint. This amounts to checking if any package-    -- satisfies the given constraint, including version range and installation-    -- status.-    ---    (available', excluded', newExcluded, anyRemaining, conflicts) =-      updatePkgsStatus-        available excluded-        [] False []-        (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')-                 (PackageIndex.lookupPackageName available pkgname)-                 (PackageIndex.lookupPackageName excluded  pkgname))--    testConstraint pkg =-      let ver = packageVersion pkg in-      case Map.lookup (packageName pkg) paired of--        Just (v1, v2)-          | ver == v1 || ver == v2-          -> case pkg of-               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)-               SourceOnly    spkg -> SourceOnly    (spkg, sOk)-               InstalledAndSource ipkg spkg ->-                 InstalledAndSource (ipkg, iOk) (spkg, sOk)-          where-            iOk = constraint v1 True  || constraint v2 True-            sOk = constraint v1 False || constraint v2 False--        _ -> case pkg of-               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)-               SourceOnly    spkg -> SourceOnly    (spkg, sOk)-               InstalledAndSource ipkg spkg ->-                 InstalledAndSource (ipkg, iOk) (spkg, sOk)-          where-            iOk = constraint ver True-            sOk = constraint ver False--    -- For the info about available and excluded versions of the package in-    -- question, update the info given the current constraint-    ---    -- We update the available package map and the excluded package map-    -- we also collect:-    --   * the change in available packages (for logging)-    --   * whether there are any remaining choices-    --   * any constraints that conflict with the current constraint--    updatePkgsStatus _ _ nePkgs ok cs _-      | seq nePkgs $ seq ok $ seq cs False = undefined--    updatePkgsStatus aPkgs ePkgs nePkgs ok cs []-      = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs)--    updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =-        let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg-            nePkgs' = maybeCons mnePkg nePkgs-            cs'     = maybeCons mc cs-         in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs--    maybeCons Nothing  xs = xs-    maybeCons (Just x) xs = x:xs---    -- For the info about an available or excluded version of the package in-    -- question, update the info given the current constraint.-    ---    updatePkgStatus aPkgs ePkgs pkg =-      case viewPackageStatus pkg of-        AllAvailable (InstalledOnly (aiPkg, False)) ->-          removeAvailable False-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])-            Nothing--        AllAvailable (SourceOnly (asPkg, False)) ->-          removeAvailable False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->-          removeAvailable False-            (InstalledAndSource aiPkg asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->-          removeAvailable True-            (SourceOnly asPkg)-            (PackageIndex.insert (InstalledOnly aiPkg))-            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])-            Nothing--        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->-          removeAvailable True-            (InstalledOnly aiPkg)-            (PackageIndex.insert (SourceOnly asPkg))-            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])-            Nothing--        AllAvailable _ -> noChange True Nothing--        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->-          removeAvailable False-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)-            Nothing--        AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->-          addExtraExclusion True-            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))-            Nothing--        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->-          removeAvailable  True-            (InstalledOnly aiPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)-            (Just (pkgid, srs))--        AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->-          noChange True-            (Just (pkgid, srs))--        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->-          removeAvailable  False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])-            Nothing--        ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->-          removeAvailable False-            (SourceOnly asPkg)-            (PackageIndex.deletePackageId pkgid)-            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])-            (Just (pkgid, irs))--        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->-          addExtraExclusion True-            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])-            Nothing--        ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->-          noChange True-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])-            Nothing--        AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->-          noChange False-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->-          addExtraExclusion False-            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))-            Nothing--        AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->-          noChange False-            (Just (pkgid, srs))--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)-            Nothing--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))-            (Just (pkgid, irs))--        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->-          addExtraExclusion False-            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)-            (Just (pkgid, srs))--        AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->-          noChange False-            (Just (pkgid, isrs ++ irs ++ srs))--      where-        removeAvailable ok nePkg adjustAvailable ePkg c =-          let aPkgs' = adjustAvailable aPkgs-              ePkgs' = PackageIndex.insert ePkg ePkgs-           in aPkgs' `seq` ePkgs' `seq`-              (aPkgs', ePkgs', Just nePkg, ok, c)--        addExtraExclusion ok ePkg c =-          let ePkgs' = PackageIndex.insert ePkg ePkgs-           in ePkgs' `seq`-              (aPkgs, ePkgs', Nothing, ok, c)--        noChange ok c =-          (aPkgs, ePkgs, Nothing, ok, c)--        pkgid = case pkg of OnlyInLeft  p   -> packageId p-                            OnlyInRight p   -> packageId p-                            InBoth      p _ -> packageId p---    viewPackageStatus-      :: (Package installed, Package source)-      => MergeResult (InstalledOrSource installed source)-                     (ExcludedPkg (InstalledOrSource installed source) reason)-      -> PackageStatus (installed, Bool) (source, Bool) reason-    viewPackageStatus merged =-        case merged of-          OnlyInLeft aPkg ->-            AllAvailable (testConstraint aPkg)--          OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->-            AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)--          InBoth (InstalledOnly aiPkg)-                 (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->-            case testConstraint (InstalledAndSource aiPkg esPkg) of-              InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->-                AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)-              _ -> impossible--          InBoth (SourceOnly asPkg)-                 (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->-            case testConstraint (InstalledAndSource eiPkg asPkg) of-              InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->-                ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)-              _ -> impossible-          _ -> impossible-      where-        impossible = error "impossible: viewPackageStatus invariant violation"---- A intermediate structure that enumerates all the possible cases given the--- invariant. This helps us to get simpler and complete pattern matching in--- updatePkg above----data PackageStatus installed source reason-   = AllAvailable (InstalledOrSource installed source)-   | AllExcluded  (ExcludedPkg (InstalledOrSource installed source) reason)-   | AvailableExcluded installed (ExcludedPkg source reason)-   | ExcludedAvailable (ExcludedPkg installed reason) source---conflicting :: (Package installed, Package source)-            => Constraints installed source reason-            -> Dependency-            -> [(PackageId, [reason])]-conflicting (Constraints _ _ excluded _ _) dep =-  [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO-  | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <--      PackageIndex.lookupDependency excluded dep ]
− Distribution/Client/Dependency/TopDown/Types.hs 
@@ -1,143 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Types for the top-down dependency resolver.-------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.TopDown.Types where--import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..)-         , OptionalStanza, ConfiguredId(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.Client.ComponentDeps as CD--import Distribution.Package-         ( PackageId, PackageIdentifier, Dependency-         , Package(packageId) )-import Distribution.PackageDescription-         ( FlagAssignment )---- --------------------------------------------------------------- * The various kinds of packages--- --------------------------------------------------------------type SelectablePackage-   = InstalledOrSource InstalledPackageEx UnconfiguredPackage--type SelectedPackage-   = InstalledOrSource InstalledPackageEx SemiConfiguredPackage--data InstalledOrSource installed source-   = InstalledOnly      installed-   | SourceOnly                   source-   | InstalledAndSource installed source-  deriving Eq--data FinalSelectedPackage-   = SelectedInstalled InstalledPackage-   | SelectedSource    ConfiguredPackage--type TopologicalSortNumber = Int---- | InstalledPackage caches its dependencies as source package IDs.-data InstalledPackage-   = InstalledPackage-       InstalledPackageInfo-       [PackageId]--data InstalledPackageEx-   = InstalledPackageEx-       InstalledPackage-       !TopologicalSortNumber-       [PackageIdentifier]    -- transitive closure of installed deps--data UnconfiguredPackage-   = UnconfiguredPackage-       SourcePackage-       !TopologicalSortNumber-       FlagAssignment-       [OptionalStanza]--data SemiConfiguredPackage-   = SemiConfiguredPackage-       SourcePackage     -- package info-       FlagAssignment    -- total flag assignment for the package-       [OptionalStanza]  -- enabled optional stanzas-       [Dependency]      -- dependencies we end up with when we apply-                         -- the flag assignment--instance Package InstalledPackage where-  packageId (InstalledPackage pkg _) = packageId pkg--instance Package InstalledPackageEx where-  packageId (InstalledPackageEx p _ _) = packageId p--instance Package UnconfiguredPackage where-  packageId (UnconfiguredPackage p _ _ _) = packageId p--instance Package SemiConfiguredPackage where-  packageId (SemiConfiguredPackage p _ _ _) = packageId p--instance (Package installed, Package source)-      => Package (InstalledOrSource installed source) where-  packageId (InstalledOnly      p  ) = packageId p-  packageId (SourceOnly         p  ) = packageId p-  packageId (InstalledAndSource p _) = packageId p--instance Package FinalSelectedPackage where-  packageId (SelectedInstalled pkg) = packageId pkg-  packageId (SelectedSource    pkg) = packageId pkg----- | We can have constraints on selecting just installed or just source--- packages.------ In particular, installed packages can only depend on other installed--- packages while packages that are not yet installed but which we plan to--- install can depend on installed or other not-yet-installed packages.----data InstalledConstraint = InstalledConstraint-                         | SourceConstraint-  deriving (Eq, Show)---- | Package dependencies------ The top-down solver uses its down type class for package dependencies,--- because it wants to know these dependencies as PackageIds, rather than as--- ComponentIds (so it cannot use PackageFixedDeps).------ Ideally we would switch the top-down solver over to use ComponentIds--- throughout; that means getting rid of this type class, and changing over the--- package index type to use Cabal's rather than cabal-install's. That will--- avoid the need for the local definitions of dependencyGraph and--- reverseTopologicalOrder in the top-down solver.------ Note that the top-down solver does not (and probably will never) make a--- distinction between the various kinds of dependencies, so we return a flat--- list here. If we get rid of this type class then any use of `sourceDeps`--- should be replaced by @fold . depends@.-class Package a => PackageSourceDeps a where-  sourceDeps :: a -> [PackageIdentifier]--instance PackageSourceDeps InstalledPackageEx where-  sourceDeps (InstalledPackageEx _ _ deps) = deps--instance PackageSourceDeps ConfiguredPackage where-  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps--instance PackageSourceDeps InstalledPackage where-  sourceDeps (InstalledPackage _ deps) = deps--instance PackageSourceDeps FinalSelectedPackage where-  sourceDeps (SelectedInstalled pkg) = sourceDeps pkg-  sourceDeps (SelectedSource    pkg) = sourceDeps pkg-
Distribution/Client/Dependency/Types.hs view
@@ -1,193 +1,45 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.------------------------------------------------------------------------------ module Distribution.Client.Dependency.Types (     PreSolver(..),     Solver(..),-    DependencyResolver,-    ResolverPackage(..), -    PackageConstraint(..),-    showPackageConstraint,-    PackagePreferences(..),-    InstalledPreference(..),     PackagesPreferenceDefault(..), -    Progress(..),-    foldProgress,--    LabeledPackageConstraint(..),-    ConstraintSource(..),-    unlabelPackageConstraint,-    showConstraintSource-   ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-         ( Applicative(..) )-#endif-import Control.Applicative-         ( Alternative(..) )- import Data.Char          ( isAlpha, toLower )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif -import Distribution.Client.PkgConfigDb-         ( PkgConfigDb )-import Distribution.Client.Types-         ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage )- import qualified Distribution.Compat.ReadP as Parse          ( pfail, munch1 )-import Distribution.PackageDescription-         ( FlagAssignment, FlagName(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.Client.PackageIndex as PackageIndex-         ( PackageIndex )-import Distribution.Simple.PackageIndex ( InstalledPackageIndex )-import Distribution.Package-         ( PackageName )-import Distribution.Version-         ( VersionRange, simplifyVersionRange )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.System-         ( Platform ) import Distribution.Text-         ( Text(..), display )+         ( Text(..) )  import Text.PrettyPrint          ( text ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) -import Prelude hiding (fail) - -- | All the solvers that can be selected.-data PreSolver = AlwaysTopDown | AlwaysModular | Choose+data PreSolver = AlwaysModular   deriving (Eq, Ord, Show, Bounded, Enum, Generic)  -- | All the solvers that can be used.-data Solver = TopDown | Modular+data Solver = Modular   deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance Binary PreSolver instance Binary Solver  instance Text PreSolver where-  disp AlwaysTopDown = text "topdown"   disp AlwaysModular = text "modular"-  disp Choose        = text "choose"   parse = do     name <- Parse.munch1 isAlpha     case map toLower name of-      "topdown" -> return AlwaysTopDown       "modular" -> return AlwaysModular-      "choose"  -> return Choose       _         -> Parse.pfail --- | 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 = Platform-                       -> CompilerInfo-                       -> InstalledPackageIndex-                       ->          PackageIndex.PackageIndex SourcePackage-                       -> PkgConfigDb-                       -> (PackageName -> PackagePreferences)-                       -> [LabeledPackageConstraint]-                       -> [PackageName]-                       -> Progress String String [ResolverPackage]---- | 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 = PreExisting InstalledPackageInfo-                     | Configured  ConfiguredPackage---- | 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).----data PackageConstraint-   = PackageConstraintVersion   PackageName VersionRange-   | PackageConstraintInstalled PackageName-   | PackageConstraintSource    PackageName-   | PackageConstraintFlags     PackageName FlagAssignment-   | PackageConstraintStanzas   PackageName [OptionalStanza]-  deriving (Eq,Show,Generic)--instance Binary PackageConstraint---- | Provide a textual representation of a package constraint--- for debugging purposes.----showPackageConstraint :: PackageConstraint -> String-showPackageConstraint (PackageConstraintVersion pn vr) =-  display pn ++ " " ++ display (simplifyVersionRange vr)-showPackageConstraint (PackageConstraintInstalled pn) =-  display pn ++ " installed"-showPackageConstraint (PackageConstraintSource pn) =-  display pn ++ " source"-showPackageConstraint (PackageConstraintFlags pn fs) =-  "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs)-  where-    showFlag (FlagName f) True  = "+" ++ f-    showFlag (FlagName f) False = "-" ++ f-showPackageConstraint (PackageConstraintStanzas pn ss) =-  "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)-  where-    showStanza TestStanzas  = "test"-    showStanza BenchStanzas = "bench"---- | 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]---- | Whether we prefer an installed version of a package or simply the latest--- version.----data InstalledPreference = PreferInstalled | PreferLatest-  deriving Show- -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. --@@ -212,107 +64,3 @@      --    | PreferLatestForSelected   deriving Show---- | 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-  deriving (Functor)---- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two--- base cases, one for a final result and one for failure.------ 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---- | 'PackageConstraint' labeled with its source.-data LabeledPackageConstraint-   = LabeledPackageConstraint PackageConstraint ConstraintSource--unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint-unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc---- | 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-  deriving (Eq, Show, Generic)--instance Binary 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"
Distribution/Client/DistDirLayout.hs view
@@ -5,37 +5,83 @@ -- The layout of the .\/dist\/ directory where cabal keeps all of it's state -- and build artifacts. ---module Distribution.Client.DistDirLayout where+module Distribution.Client.DistDirLayout (+    -- * 'DistDirLayout'+    DistDirLayout(..),+    DistDirParams(..),+    defaultDistDirLayout,+    ProjectRoot(..), +    -- * 'StoreDirLayout'+    StoreDirLayout(..),+    defaultStoreDirLayout,++    -- * 'CabalDirLayout'+    CabalDirLayout(..),+    defaultCabalDirLayout,+) where++import Data.Maybe (fromMaybe) import System.FilePath+ import Distribution.Package-         ( PackageId )+         ( PackageId, ComponentId, UnitId ) import Distribution.Compiler-import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Simple.Compiler+         ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) import Distribution.Text-import Distribution.Client.Types-         ( InstalledPackageId )+import Distribution.Types.ComponentName+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 dist directory, which is the root of where cabal keeps all its-       -- state including the build artifacts from each package we build.+       -- | 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 'PackageId' not just a 'PackageName' because technically+       -- 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           :: PackageId -> FilePath,+       distBuildDirectory           :: DistDirParams -> FilePath,        distBuildRootDirectory       :: FilePath,         -- | The directory under dist where we put the unpacked sources of@@ -55,8 +101,8 @@        -- | The location for package-specific cache files (e.g. state used in        -- incremental rebuilds).        ---       distPackageCacheFile         :: PackageId -> String -> FilePath,-       distPackageCacheDirectory    :: PackageId -> FilePath,+       distPackageCacheFile         :: DistDirParams -> String -> FilePath,+       distPackageCacheDirectory    :: DistDirParams -> FilePath,         distTempDirectory            :: FilePath,        distBinDirectory             :: FilePath,@@ -65,30 +111,91 @@      }  +-- | 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 {-       cabalStoreDirectory        :: CompilerId -> FilePath,-       cabalStorePackageDirectory :: CompilerId -> InstalledPackageId-                                                -> FilePath,-       cabalStorePackageDBPath    :: CompilerId -> FilePath,-       cabalStorePackageDB        :: CompilerId -> PackageDB,+       cabalStoreDirLayout        :: StoreDirLayout, -       cabalPackageCacheDirectory :: FilePath,        cabalLogsDirectory         :: FilePath,        cabalWorldFile             :: FilePath      }  -defaultDistDirLayout :: FilePath -> DistDirLayout-defaultDistDirLayout projectRootDirectory =+-- | Information about the root directory of the project.+--+-- It can either be an implict project root in the current dir if no+-- @cabal.project@ file is found, or an explicit root if the file is found.+--+data ProjectRoot =+       -- | -- ^ An implict project root. It contains the absolute project+       -- 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-    distDirectory = projectRootDirectory </> "dist-newstyle"+    (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 pkgid = distBuildRootDirectory </> display pkgid+    distBuildDirectory params =+        distBuildRootDirectory </>+        display (distParamPlatform params) </>+        display (distParamCompilerId params) </>+        display (distParamPackageId params) </>+        (case fmap componentNameString (distParamComponentName params) of+            Nothing          -> ""+            Just Nothing     -> ""+            Just (Just name) -> "c" </> display name) </>+        (case distParamOptimization params of+            NoOptimisation -> "noopt"+            NormalOptimisation -> ""+            MaximumOptimisation -> "opt") </>+        (let uid_str = display (distParamUnitId params)+         in if uid_str == display (distParamComponentId params)+                then ""+                else uid_str)      distUnpackedSrcRootDirectory   = distDirectory </> "src"     distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory@@ -97,8 +204,8 @@     distProjectCacheDirectory = distDirectory </> "cache"     distProjectCacheFile name = distProjectCacheDirectory </> name -    distPackageCacheDirectory pkgid = distBuildDirectory pkgid </> "cache"-    distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid </> name+    distPackageCacheDirectory params = distBuildDirectory params </> "cache"+    distPackageCacheFile params name = distPackageCacheDirectory params </> name      distTempDirectory = distDirectory </> "tmp" @@ -108,25 +215,38 @@     distPackageDB = SpecificPackageDB . distPackageDBPath  --defaultCabalDirLayout :: FilePath -> CabalDirLayout-defaultCabalDirLayout cabalDir =-    CabalDirLayout {..}+defaultStoreDirLayout :: FilePath -> StoreDirLayout+defaultStoreDirLayout storeRoot =+    StoreDirLayout {..}   where+    storeDirectory compid =+      storeRoot </> display compid -    cabalStoreDirectory compid =-      cabalDir </> "store" </> display compid+    storePackageDirectory compid ipkgid =+      storeDirectory compid </> display ipkgid -    cabalStorePackageDirectory compid ipkgid = -      cabalStoreDirectory compid </> display ipkgid+    storePackageDBPath compid =+      storeDirectory compid </> "package.db" -    cabalStorePackageDBPath compid =-      cabalStoreDirectory compid </> "package.db"+    storePackageDB compid =+      SpecificPackageDB (storePackageDBPath compid) -    cabalStorePackageDB =-      SpecificPackageDB . cabalStorePackageDBPath+    storePackageDBStack compid =+      [GlobalPackageDB, storePackageDB compid] -    cabalPackageCacheDirectory = cabalDir </> "packages"+    storeIncomingDirectory compid =+      storeDirectory compid </> "incoming"++    storeIncomingLock compid unitid =+      storeIncomingDirectory compid </> display unitid <.> "lock"+++defaultCabalDirLayout :: FilePath -> CabalDirLayout+defaultCabalDirLayout cabalDir =+    CabalDirLayout {..}+  where++    cabalStoreDirLayout = defaultStoreDirLayout (cabalDir </> "store")      cabalLogsDirectory = cabalDir </> "logs"
Distribution/Client/Exec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Exec@@ -12,7 +11,8 @@ module Distribution.Client.Exec ( exec                                 ) where -import Control.Monad (unless)+import Prelude ()+import Distribution.Client.Compat.Prelude  import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS@@ -27,17 +27,14 @@ import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )-import Distribution.Simple.Utils       (die, warn)+import Distribution.Simple.Utils       (die', warn) -import Distribution.System    (Platform)+import Distribution.System    (Platform(..), OS(..), buildOS) import Distribution.Verbosity (Verbosity)  import System.Directory ( doesDirectoryExist )+import System.Environment (lookupEnv) import System.FilePath (searchPathSeparator, (</>))-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (mempty)-#endif   -- | Execute the given command in the package's environment.@@ -55,19 +52,19 @@     case extraArgs of         (exe:args) -> do             program <- requireProgram' verbosity useSandbox programDb exe-            env <- ((++) (programOverrideEnv program)) <$> environmentOverrides+            env <- environmentOverrides (programOverrideEnv program)             let invocation = programInvocation                                  program { programOverrideEnv = env }                                  args             runProgramInvocation verbosity invocation -        [] -> die "Please specify an executable to run"+        [] -> die' verbosity "Please specify an executable to run"   where-    environmentOverrides =+    environmentOverrides env =         case useSandbox of-            NoSandbox -> return []+            NoSandbox -> return env             (UseSandbox sandboxDir) ->-                sandboxEnvironment verbosity sandboxDir comp platform programDb+                sandboxEnvironment verbosity sandboxDir comp platform programDb env   -- | Return the package's sandbox environment.@@ -78,13 +75,19 @@                    -> Compiler                    -> Platform                    -> ProgramDb+                   -> [(String, Maybe String)] -- environment overrides so far                    -> IO [(String, Maybe String)]-sandboxEnvironment verbosity sandboxDir comp platform programDb =+sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv =     case compilerFlavor comp of       GHC   -> env GHC.getGlobalPackageDB   ghcProgram   "GHC_PACKAGE_PATH"       GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH"-      _     -> die "exec only works with GHC and GHCJS"+      _     -> die' verbosity "exec only works with GHC and GHCJS"   where+    (Platform _ os) = platform+    ldPath = case os of+               OSX     -> "DYLD_LIBRARY_PATH"+               Windows -> "PATH"+               _       -> "LD_LIBRARY_PATH"     env getGlobalPackageDB hcProgram packagePathEnvVar = do         let Just program = lookupProgram hcProgram programDb         gDb <- getGlobalPackageDB verbosity program@@ -96,14 +99,64 @@         exists <- doesDirectoryExist sandboxPackagePath         unless exists $ warn verbosity $ "Package database is not a directory: "                                            ++ sandboxPackagePath+        -- MASSIVE HACK.  We need this to be synchronized with installLibDir+        -- in defaultInstallDirs' in Distribution.Simple.InstallDirs,+        -- which has a special case for Windows (WHY? Who knows; it's been+        -- around as long as Windows exists.)  The sane thing to do here+        -- would be to read out the actual install dirs that were associated+        -- with the package in question, but that's not a well-formed question+        -- here because there is not actually install directory for the+        -- "entire" sandbox.  Since we want to kill this code in favor of+        -- new-build, I decided it wasn't worth fixing this "properly."+        -- Also, this doesn't handle LHC correctly but I don't care -- ezyang+        let extraLibPath =+                case buildOS of+                    Windows -> sandboxDir+                    _ -> sandboxDir </> "lib"+        -- 2016-11-26 Apologies for the spaghetti code here.+        -- Essentially we just want to add the sandbox's lib/ dir to+        -- whatever the library search path environment variable is:+        -- this allows running existing executables against foreign+        -- libraries (meaning Haskell code with a bunch of foreign+        -- exports). However, on Windows this variable is equal to the+        -- executable search path env var. And we try to keep not only+        -- what was already set in the environment, but also the+        -- additional directories we add below in requireProgram'. So+        -- the strategy is that we first take the environment+        -- overrides from requireProgram' below. If the library search+        -- path env is overridden (e.g. because we're on windows), we+        -- prepend the lib/ dir to the relevant override. If not, we+        -- want to avoid wiping the user's own settings, so we first+        -- read the env var's current value, and then prefix ours if+        -- the user had any set.+        iEnv' <-+          if any ((==ldPath) . fst) iEnv+            then return $ updateLdPath extraLibPath iEnv+            else do+              currentLibraryPath <- lookupEnv ldPath+              let updatedLdPath =+                    case currentLibraryPath of+                      Nothing -> Just extraLibPath+                      Just paths ->+                        Just $ extraLibPath ++ [searchPathSeparator] ++ paths+              return $ (ldPath, updatedLdPath) : iEnv+         -- Build the environment-        return [ (packagePathEnvVar, Just compilerPackagePaths)-               , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)-               , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)-               ]+        return $ [ (packagePathEnvVar, Just compilerPackagePaths)+                 , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)+                 , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)+                 ] ++ iEnv'      prependToSearchPath path newValue =         newValue ++ [searchPathSeparator] ++ path++    updateLdPath path = map update+      where+        update (name, Just current)+          | name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current)+        update (name, Nothing)+          | name == ldPath = (ldPath, Just path)+        update x = x   -- | Check that a program is configured and available to be run. If
Distribution/Client/Fetch.hs view
@@ -21,23 +21,25 @@ import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) +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-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Setup          ( fromFlag ) import Distribution.Simple.Utils-         ( die, notice, debug )+         ( die', notice, debug ) import Distribution.System          ( Platform ) import Distribution.Text@@ -69,7 +71,7 @@       -> RepoContext       -> Compiler       -> Platform-      -> ProgramConfiguration+      -> ProgramDb       -> GlobalFlags       -> FetchFlags       -> [UserTarget]@@ -77,14 +79,14 @@ fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repoCtxt comp platform conf+fetch verbosity packageDBs repoCtxt comp platform progdb       globalFlags fetchFlags userTargets = do -    mapM_ checkTarget userTargets+    mapM_ (checkTarget verbosity) userTargets -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)@@ -120,8 +122,8 @@              -> InstalledPackageIndex              -> SourcePackageDb              -> PkgConfigDb-             -> [PackageSpecifier SourcePackage]-             -> IO [SourcePackage]+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> IO [UnresolvedSourcePackage] planPackages verbosity comp platform fetchFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers @@ -129,7 +131,7 @@       solver <- chooseSolver verbosity                 (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp)       notice verbosity "Resolving dependencies..."-      installPlan <- foldProgress logMsg die return $+      installPlan <- foldProgress logMsg (die' verbosity) return $                        resolveDependencies                          platform (compilerInfo comp) pkgConfigDb                          solver@@ -138,12 +140,12 @@       -- The packages we want to fetch are those packages the 'InstallPlan'       -- that are in the 'InstallPlan.Configured' state.       return-        [ pkg-        | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _))-            <- InstallPlan.toList installPlan ]+        [ solverPkgSource cpkg+        | (SolverInstallPlan.Configured cpkg)+            <- SolverInstallPlan.toList installPlan ]    | otherwise =-      either (die . unlines . map show) return $+      either (die' verbosity . unlines . map show) return $         resolveWithoutDependencies resolverParams    where@@ -156,10 +158,16 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setShadowPkgs shadowPkgs        . setStrongFlags strongFlags +      . setAllowBootLibInstalls allowBootLibInstalls++      . setSolverVerbosity verbosity+         -- 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@@ -172,16 +180,18 @@     logMsg message rest = debug verbosity message >> rest      reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)+    countConflicts   = fromFlag (fetchCountConflicts   fetchFlags)     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)     shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)     strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)+    allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)  -checkTarget :: UserTarget -> IO ()-checkTarget target = case target of+checkTarget :: Verbosity -> UserTarget -> IO ()+checkTarget verbosity target = case target of     UserTargetRemoteTarball _uri-      -> die $ "The 'fetch' command does not yet support remote tarballs. "+      -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "             ++ "In the meantime you can use the 'unpack' commands."     _ -> return () @@ -191,7 +201,7 @@     LocalTarballPackage  _file -> return ()      RemoteTarballPackage _uri _ ->-      die $ "The 'fetch' command does not yet support remote tarballs. "+      die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "          ++ "In the meantime you can use the 'unpack' commands."      RepoTarballPackage repo pkgid _ -> do
Distribution/Client/FetchUtils.hs view
@@ -23,6 +23,11 @@     checkRepoTarballFetched,     fetchRepoTarball, +    -- ** fetching packages asynchronously+    asyncFetchPackages,+    waitAsyncFetchPackage,+    AsyncFetchMap,+     -- * fetching other things     downloadIndex,   ) where@@ -35,15 +40,21 @@ import Distribution.Package          ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils-         ( notice, info, setupMessage )+         ( notice, info, debug, setupMessage ) import Distribution.Text          ( display ) import Distribution.Verbosity-         ( Verbosity )+         ( Verbosity, verboseUnmarkOutput ) import Distribution.Client.GlobalFlags          ( RepoContext(..) )  import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad+import Control.Exception+import Control.Concurrent.Async+import Control.Concurrent.MVar import System.Directory          ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.IO@@ -64,20 +75,19 @@ -- | Returns @True@ if the package has already been fetched -- or does not need fetching. ---isFetched :: PackageLocation (Maybe FilePath) -> IO Bool+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) - -- | 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 :: PackageLocation (Maybe FilePath)-             -> IO (Maybe (PackageLocation FilePath))+checkFetched :: UnresolvedPkgLoc+             -> IO (Maybe ResolvedPkgLoc) checkFetched loc = case loc of     LocalUnpackedPackage dir  ->       return (Just $ LocalUnpackedPackage dir)@@ -109,8 +119,8 @@ -- fetchPackage :: Verbosity              -> RepoContext-             -> PackageLocation (Maybe FilePath)-             -> IO (PackageLocation FilePath)+             -> UnresolvedPkgLoc+             -> IO ResolvedPkgLoc fetchPackage verbosity repoCtxt loc = case loc of     LocalUnpackedPackage dir  ->       return (LocalUnpackedPackage dir)@@ -130,7 +140,7 @@   where     downloadTarballPackage uri = do       transport <- repoContextGetTransport repoCtxt-      transportCheckHttps transport uri+      transportCheckHttps verbosity transport uri       notice verbosity ("Downloading " ++ show uri)       tmpdir <- getTemporaryDirectory       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"@@ -155,7 +165,7 @@        RepoRemote{..} -> do         transport <- repoContextGetTransport repoCtxt-        remoteRepoCheckHttps transport repoRemote+        remoteRepoCheckHttps verbosity transport repoRemote         let uri  = packageURI  repoRemote pkgid             dir  = packageDir  repo       pkgid             path = packageFile repo       pkgid@@ -172,11 +182,13 @@           Sec.downloadPackage' rep pkgid path         return path --- | Downloads an index file to [config-dir/packages/serv-id].+-- | 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 transport remoteRepo+  remoteRepoCheckHttps verbosity transport remoteRepo   let uri = (remoteRepoURI remoteRepo) {               uriPath = uriPath (remoteRepoURI remoteRepo)                           `FilePath.Posix.combine` "00-index.tar.gz"@@ -184,6 +196,69 @@       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 <- sequence [ do v <- newEmptyMVar+                                       return (pkgloc, v)+                                  | pkgloc <- pkglocs ]++    let fetchPackages :: IO ()+        fetchPackages =+          forM_ 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"   -- ------------------------------------------------------------
Distribution/Client/FileMonitor.hs view
@@ -15,6 +15,7 @@   monitorFile,   monitorFileHashed,   monitorNonExistentFile,+  monitorFileExistence,   monitorDirectory,   monitorNonExistentDirectory,   monitorDirectoryExistence,@@ -35,23 +36,18 @@   beginUpdateFileMonitor,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude  #if MIN_VERSION_containers(0,5,0)-import           Data.Map.Strict (Map) import qualified Data.Map.Strict as Map #else-import           Data.Map        (Map) import qualified Data.Map        as Map #endif import qualified Data.ByteString.Lazy as BS-import           Distribution.Compat.Binary import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable-import           Data.List (sort) -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif import           Control.Monad import           Control.Monad.Trans (MonadIO, liftIO) import           Control.Monad.State (StateT, mapStateT)@@ -60,7 +56,7 @@                                        throwError) import           Control.Exception -import           Distribution.Client.Compat.Time+import           Distribution.Compat.Time import           Distribution.Client.Glob import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import           Distribution.Client.Utils (mergeBy, MergeResult(..))@@ -68,9 +64,7 @@ import           System.FilePath import           System.Directory import           System.IO-import           GHC.Generics (Generic) - ------------------------------------------------------------------------------ -- Types for specifying files to monitor --@@ -130,6 +124,12 @@ 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.@@ -199,8 +199,13 @@ -- files to be monitored (index by their path), and a list of -- globs, which monitor may files at once. data MonitorStateFileSet-   = MonitorStateFileSet !(Map FilePath MonitorStateFile)+   = 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  type Hash = Int@@ -216,7 +221,7 @@ -- no longer exists at all. -- data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir-                                         !MonitorStateFileStatus+                                         !FilePath !MonitorStateFileStatus   deriving (Show, Generic)  data MonitorStateFileStatus@@ -262,11 +267,10 @@ -- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =-    Map.foldrWithKey (\k x r -> getSinglePath k x : r)-                     (map getGlobPath globPaths)-                     singlePaths+    map getSinglePath singlePaths+ ++ map getGlobPath globPaths   where-    getSinglePath filepath (MonitorStateFile kindfile kinddir _) =+    getSinglePath (MonitorStateFile kindfile kinddir filepath _) =       MonitorFile kindfile kinddir filepath      getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =@@ -516,7 +520,7 @@   runChangedM $ do     sequence_       [ probeMonitorStateFileStatus root file status-      | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ]+      | MonitorStateFile _ _ file status <- singlePaths ]     -- The glob monitors can require state changes     globPaths' <-       sequence@@ -793,19 +797,19 @@                                               --   relative to root                          -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root =-    go Map.empty []+    go [] []   where-    go :: Map FilePath MonitorStateFile -> [MonitorStateGlob]+    go :: [MonitorStateFile] -> [MonitorStateGlob]        -> [MonitorFilePath] -> IO MonitorStateFileSet     go !singlePaths !globPaths [] =-      return (MonitorStateFileSet singlePaths globPaths)+      return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))      go !singlePaths !globPaths        (MonitorFile kindfile kinddir path : monitors) = do-      monitorState <- MonitorStateFile kindfile kinddir+      monitorState <- MonitorStateFile kindfile kinddir path                   <$> buildMonitorStateFile mstartTime hashcache                                             kindfile kinddir root path-      go (Map.insert path monitorState singlePaths) globPaths monitors+      go (monitorState : singlePaths) globPaths monitors      go !singlePaths !globPaths        (MonitorFileGlob kindfile kinddir globPath : monitors) = do@@ -976,15 +980,15 @@                     collectAllFileHashes singlePaths         `Map.union` collectAllGlobHashes globPaths -    collectAllFileHashes =-      Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of-        MonitorStateFileHashed mtime hash -> Just (mtime, hash)-        _                                 -> Nothing+    collectAllFileHashes singlePaths =+      Map.fromList [ (fpath, (mtime, hash))+                   | MonitorStateFile _ _ fpath+                       (MonitorStateFileHashed mtime hash) <- singlePaths ]      collectAllGlobHashes globPaths =-      Map.fromList [ (fpath, hash)+      Map.fromList [ (fpath, (mtime, hash))                    | MonitorStateGlob _ _ _ gstate <- globPaths-                   , (fpath, hash) <- collectGlobHashes "" gstate ]+                   , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]      collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =       [ res
Distribution/Client/Freeze.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Freeze@@ -16,19 +15,18 @@     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.Dependency.Types-         ( ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import Distribution.Client.InstallPlan-         ( InstallPlan, PlanPackage )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+import Distribution.Client.SolverInstallPlan+         ( SolverInstallPlan, SolverPlanPackage )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)          , RepoContext(..) )@@ -38,17 +36,23 @@ import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) ) +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-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Setup          ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils-         ( die, notice, debug, writeFileAtomic )+         ( die', notice, debug, writeFileAtomic ) import Distribution.System          ( Platform ) import Distribution.Text@@ -56,15 +60,7 @@ import Distribution.Verbosity          ( Verbosity ) -import Control.Monad-         ( when ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( mempty )-#endif-import Data.Version-         ( showVersion ) import Distribution.Version          ( thisVersion ) @@ -76,20 +72,20 @@ -- constraining each dependency to an exact version. -- freeze :: Verbosity-      -> PackageDBStack-      -> RepoContext-      -> Compiler-      -> Platform-      -> ProgramConfiguration-      -> Maybe SandboxPackageInfo-      -> GlobalFlags-      -> FreezeFlags-      -> IO ()-freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+       -> PackageDBStack+       -> RepoContext+       -> Compiler+       -> Platform+       -> ProgramDb+       -> Maybe SandboxPackageInfo+       -> GlobalFlags+       -> FreezeFlags+       -> IO ()+freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do      pkgs  <- getFreezePkgs-               verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+               verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo                globalFlags freezeFlags      if null pkgs@@ -112,17 +108,17 @@               -> RepoContext               -> Compiler               -> Platform-              -> ProgramConfiguration+              -> ProgramDb               -> Maybe SandboxPackageInfo               -> GlobalFlags               -> FreezeFlags-              -> IO [PlanPackage]-getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+              -> IO [SolverPlanPackage]+getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb      pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)@@ -136,10 +132,10 @@   where     sanityCheck pkgSpecifiers = do       when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $-        die $ "internal error: 'resolveUserTargets' returned "+        die' verbosity $ "internal error: 'resolveUserTargets' returned "            ++ "unexpected named package specifiers!"       when (length pkgSpecifiers /= 1) $-        die $ "internal error: 'resolveUserTargets' returned "+        die' verbosity $ "internal error: 'resolveUserTargets' returned "            ++ "unexpected source package specifiers!"  planPackages :: Verbosity@@ -150,8 +146,8 @@              -> InstalledPackageIndex              -> SourcePackageDb              -> PkgConfigDb-             -> [PackageSpecifier SourcePackage]-             -> IO [PlanPackage]+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> IO [SolverPlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do @@ -159,7 +155,7 @@             (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)   notice verbosity "Resolving dependencies..." -  installPlan <- foldProgress logMsg die return $+  installPlan <- foldProgress logMsg (die' verbosity) return $                    resolveDependencies                      platform (compilerInfo comp) pkgConfigDb                      solver@@ -177,13 +173,20 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setShadowPkgs shadowPkgs        . setStrongFlags strongFlags +      . setAllowBootLibInstalls allowBootLibInstalls++      . setSolverVerbosity verbosity+       . addConstraints           [ let pkg = pkgSpecifierTarget pkgSpecifier-                pc = PackageConstraintStanzas pkg stanzas+                pc = PackageConstraint (scopeToplevel pkg)+                                       (PackagePropertyStanzas stanzas)             in LabeledPackageConstraint pc ConstraintSourceFreeze           | pkgSpecifier <- pkgSpecifiers ] @@ -199,10 +202,12 @@     benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags      reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)+    countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)     independentGoals = fromFlag (freezeIndependentGoals freezeFlags)     shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)     strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)     maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)+    allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)   -- | Remove all unneeded packages from an install plan.@@ -214,14 +219,17 @@ -- 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.-pruneInstallPlan :: InstallPlan-                 -> [PackageSpecifier SourcePackage]-                 -> [PlanPackage]+--+-- Invariant: @pkgSpecifiers@ must refer to packages which are not+-- 'PreExisting' in the 'SolverInstallPlan'.+pruneInstallPlan :: SolverInstallPlan+                 -> [PackageSpecifier UnresolvedSourcePackage]+                 -> [SolverPlanPackage] pruneInstallPlan installPlan pkgSpecifiers =     removeSelf pkgIds $-    InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)+    SolverInstallPlan.dependencyClosure installPlan pkgIds   where-    pkgIds = [ packageId pkg+    pkgIds = [ PlannedId (packageId pkg)              | SpecificSourcePackage pkg <- pkgSpecifiers ]     removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)     removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "@@ -232,7 +240,8 @@ freezePackages verbosity globalFlags pkgs = do      pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $-                   loadUserConfig verbosity ""  (flagToMaybe . globalConstraintsFile $ globalFlags)+                   loadUserConfig verbosity ""+                   (flagToMaybe . globalConstraintsFile $ globalFlags)     writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv   where     addFrozenConstraints config =@@ -242,11 +251,12 @@             }         }     constraint pkg =-        (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)+        (pkgIdToConstraint $ packageId pkg+        ,ConstraintSourceUserConfig userPackageEnvironmentFile)       where         pkgIdToConstraint pkgId =-            UserConstraintVersion (packageName pkgId)-                                  (thisVersion $ packageVersion pkgId)+            UserConstraint (UserQualified UserQualToplevel (packageName pkgId))+                           (PackagePropertyVersion $ thisVersion (packageVersion pkgId))     createPkgEnv config = mempty { pkgEnvSavedConfig = config }     showPkgEnv = BS.Char8.pack . showPackageEnvironment @@ -256,4 +266,4 @@   where     showPkg pid = name pid ++ " == " ++ version pid     name = display . packageName-    version = showVersion . packageVersion+    version = display . packageVersion
Distribution/Client/GenBounds.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.GenBounds@@ -14,8 +15,6 @@     genBounds   ) where -import Data.Version-         ( Version(..), showVersion ) import Distribution.Client.Init          ( incVersion ) import Distribution.Client.Freeze@@ -25,26 +24,36 @@ import Distribution.Client.Setup          ( GlobalFlags(..), FreezeFlags(..), RepoContext ) import Distribution.Package-         ( Package(..), Dependency(..), PackageName(..)-         , packageName, packageVersion )+         ( Package(..), unPackageName, packageName, packageVersion ) import Distribution.PackageDescription          ( buildDepends ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( finalizePD )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+#else import Distribution.PackageDescription.Parse-         ( readPackageDescription )+         ( readGenericPackageDescription )+#endif+import Distribution.Types.ComponentRequestedSpec+         ( defaultComponentRequestedSpec )+import Distribution.Types.Dependency import Distribution.Simple.Compiler          ( Compiler, PackageDBStack, compilerInfo ) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import Distribution.Simple.Utils          ( tryFindPackageDesc ) import Distribution.System          ( Platform )+import Distribution.Text+         ( display ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Version-         ( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals+         ( Version, alterVersion+         , LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals          , orLaterVersion, earlierVersion, intersectVersionRanges ) import System.Directory          ( getCurrentDirectory )@@ -69,7 +78,7 @@            `intersectVersionRanges`            earlierVersion (incVersion 1 (vn 2))   where-    vn n = (v { versionBranch = take n (versionBranch v) })+    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.@@ -85,7 +94,7 @@     showInterval (LowerBound _ _, NoUpperBound) =       error "Error: expected upper bound...this should never happen!"     showInterval (LowerBound l _, UpperBound u _) =-      unwords [">=", showVersion l, "&& <", showVersion u]+      unwords [">=", display l, "&& <", display u]  -- | Entry point for the @gen-bounds@ command. genBounds@@ -94,22 +103,25 @@     -> RepoContext     -> Compiler     -> Platform-    -> ProgramConfiguration+    -> ProgramDb     -> Maybe SandboxPackageInfo     -> GlobalFlags     -> FreezeFlags     -> IO ()-genBounds verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo       globalFlags freezeFlags = do      let cinfo = compilerInfo comp      cwd <- getCurrentDirectory     path <- tryFindPackageDesc cwd-    gpd <- readPackageDescription verbosity path-    let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd+    gpd <- readGenericPackageDescription verbosity path+    -- NB: We don't enable tests or benchmarks, since often they+    -- don't really have useful bounds.+    let epd = finalizePD [] defaultComponentRequestedSpec+                    (const True) platform cinfo [] gpd     case epd of-      Left _ -> putStrLn "finalizePackageDescription failed"+      Left _ -> putStrLn "finalizePD failed"       Right (pd,_) -> do         let needBounds = filter (not . hasUpperBound . depVersion) $                          buildDepends pd@@ -121,7 +133,7 @@   where      go needBounds = do        pkgs  <- getFreezePkgs-                  verbosity packageDBs repoCtxt comp platform conf+                  verbosity packageDBs repoCtxt comp platform progdb                   mSandboxPkgInfo globalFlags freezeFlags         putStrLn boundsNeededMsg@@ -134,7 +146,7 @@        mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs       depName :: Dependency -> String-     depName (Dependency (PackageName nm) _) = nm+     depName (Dependency pn _) = unPackageName pn       depVersion :: Dependency -> VersionRange      depVersion (Dependency _ vr) = vr
Distribution/Client/Get.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Get@@ -18,12 +17,15 @@     get   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+ import Distribution.Package          ( PackageId, packageId, packageName ) import Distribution.Simple.Setup          ( Flag(..), fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils-         ( notice, die, info, writeFileAtomic )+         ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Text(display)@@ -37,25 +39,19 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils-        ( getSourcePackages )+        ( getSourcePackagesAtIndexState, IndexState(..) ) import Distribution.Client.Compat.Process         ( readProcessWithExitCode ) import Distribution.Compat.Exception         ( catchIO ) +import Distribution.Solver.Types.SourcePackage+ import Control.Exception          ( finally ) import Control.Monad-         ( filterM, forM_, unless, when )-import Data.List-         ( sortBy )+         ( forM_, mapM_ ) import qualified Data.Map-import Data.Maybe-         ( listToMaybe, mapMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( mempty )-#endif import Data.Ord          ( comparing ) import System.Directory@@ -66,8 +62,6 @@          ( ExitCode(..) ) import System.FilePath          ( (</>), (<.>), addTrailingPathSeparator )-import System.Process-         ( rawSystem )   -- | Entry point for the 'cabal get' command.@@ -86,16 +80,19 @@         _      -> True    unless useFork $-    mapM_ checkTarget userTargets+    mapM_ (checkTarget verbosity) userTargets -  sourcePkgDb <- getSourcePackages verbosity repoCtxt+  let idxState = fromFlagOrDefault IndexStateHead $+                       getIndexState getFlags +  sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState+   pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                    (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)                    userTargets -  pkgs <- either (die . unlines . map show) return $+  pkgs <- either (die' verbosity . unlines . map show) return $             resolveWithoutDependencies               (resolverParams sourcePkgDb pkgSpecifiers) @@ -113,13 +110,13 @@      prefix = fromFlagOrDefault "" (getDestDir getFlags) -    fork :: [SourcePackage] -> IO ()+    fork :: [UnresolvedSourcePackage] -> IO ()     fork pkgs = do       let kind = fromFlag . getSourceRepository $ getFlags       branchers <- findUsableBranchers       mapM_ (forkPackage verbosity branchers prefix kind) pkgs -    unpack :: [SourcePackage] -> IO ()+    unpack :: [UnresolvedSourcePackage] -> IO ()     unpack pkgs = do       forM_ pkgs $ \pkg -> do         location <- fetchPackage verbosity repoCtxt (packageSource pkg)@@ -141,10 +138,10 @@       where         usePristine = fromFlagOrDefault False (getPristine getFlags) -checkTarget :: UserTarget -> IO ()-checkTarget target = case target of-    UserTargetLocalDir       dir  -> die (notTarball dir)-    UserTargetLocalCabalFile file -> die (notTarball file)+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 =@@ -163,10 +160,10 @@         pkgdir     = prefix </> pkgdirname         pkgdir'    = addTrailingPathSeparator pkgdir     existsDir  <- doesDirectoryExist pkgdir-    when existsDir $ die $+    when existsDir $ die' verbosity $      "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."     existsFile  <- doesFileExist pkgdir-    when existsFile $ die $+    when existsFile $ die' verbosity $      "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."     notice verbosity $ "Unpacking to " ++ pkgdir'     Tar.extractTarGzFile prefix pkgdirname pkgPath@@ -226,7 +223,7 @@                -- be created.             -> (Maybe PD.RepoKind)                -- ^ Which repo to choose.-            -> SourcePackage+            -> SourcePackage loc                -- ^ The package to fork.             -> IO () forkPackage verbosity branchers prefix kind src = do@@ -237,11 +234,11 @@      destDirExists <- doesDirectoryExist destdir     when destDirExists $ do-        die ("The directory " ++ show destdir ++ " already exists, not forking.")+        die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.")      destFileExists  <- doesFileExist destdir     when destFileExists $ do-        die ("A file " ++ show destdir ++ " is in the way, not forking.")+        die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.")      let repos = PD.sourceRepos desc     case findBranchCmd branchers repos kind of@@ -249,11 +246,11 @@             exitCode <- io verbosity destdir             case exitCode of                 ExitSuccess -> return ()-                ExitFailure _ -> die ("Couldn't fork package " ++ pkgid)+                ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid)         Nothing -> case repos of-            [] -> die ("Package " ++ pkgid+            [] -> die' verbosity ("Package " ++ pkgid                        ++ " does not have any source repositories.")-            _ -> die ("Package " ++ pkgid+            _ -> die' verbosity ("Package " ++ pkgid                       ++ " does not have any usable source repositories.")  -- | Given a set of possible branchers, and a set of possible source@@ -295,7 +292,7 @@          Nothing -> ["branch", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("bzr: branch " ++ show src)-        rawSystem "bzr" (args dst)+        rawSystemExitCode verbosity "bzr" (args dst)  -- | Branch driver for Darcs. branchDarcs :: Brancher@@ -306,29 +303,29 @@          Nothing -> ["get", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("darcs: get " ++ show src)-        rawSystem "darcs" (args dst)+        rawSystemExitCode verbosity "darcs" (args dst)  -- | Branch driver for Git. branchGit :: Brancher branchGit = Brancher "git" $ \repo -> do     src <- PD.repoLocation repo-    let branchArgs = case PD.repoBranch repo of-         Just b -> ["--branch", b]-         Nothing -> []-    let postClone dst = case PD.repoTag repo of+    let postClone verbosity dst = case PD.repoTag repo of          Just t -> do              cwd <- getCurrentDirectory              setCurrentDirectory dst              finally-                 (rawSystem "git" (["checkout", t] ++ branchArgs))+                 (rawSystemExitCode verbosity "git" ["checkout", t])                  (setCurrentDirectory cwd)          Nothing -> return ExitSuccess     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("git: clone " ++ show src)-        code <- rawSystem "git" (["clone", src, dst] ++ branchArgs)+        code <- rawSystemExitCode verbosity "git" (["clone", src, dst] +++                    case PD.repoBranch repo of+                        Nothing -> []+                        Just b -> ["--branch", b])         case code of             ExitFailure _ -> return code-            ExitSuccess -> postClone dst+            ExitSuccess -> postClone verbosity  dst  -- | Branch driver for Mercurial. branchHg :: Brancher@@ -343,7 +340,7 @@     let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("hg: clone " ++ show src)-        rawSystem "hg" (args dst)+        rawSystemExitCode verbosity "hg" (args dst)  -- | Branch driver for Subversion. branchSvn :: Brancher@@ -352,4 +349,4 @@     let args dst = ["checkout", src, dst]     return $ BranchCmd $ \verbosity dst -> do         notice verbosity ("svn: checkout " ++ show src)-        rawSystem "svn" (args dst)+        rawSystemExitCode verbosity "svn" (args dst)
Distribution/Client/Glob.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-}  --TODO: [code cleanup] plausibly much of this module should be merged with -- similar functionality in Cabal.@@ -15,14 +15,11 @@     , getFilePathRootDirectory     ) where -import           Data.Char (toUpper)+import Prelude ()+import Distribution.Client.Compat.Prelude+ import           Data.List (stripPrefix)-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Monad-import           Distribution.Compat.Binary-import           GHC.Generics (Generic)+import           Control.Monad (mapM)  import           Distribution.Text import           Distribution.Compat.ReadP (ReadP, (<++), (+++))
Distribution/Client/GlobalFlags.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+ module Distribution.Client.GlobalFlags (     GlobalFlags(..)   , defaultGlobalFlags@@ -12,9 +13,11 @@   , withRepoContext'   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Types          ( Repo(..), RemoteRepo(..) )-import Distribution.Compat.Semigroup import Distribution.Simple.Setup          ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList@@ -26,22 +29,15 @@ import Distribution.Simple.Utils          ( info ) -import Data.Maybe-         ( fromMaybe ) import Control.Concurrent          ( MVar, newMVar, modifyMVar ) import Control.Exception          ( throwIO )-import Control.Monad-         ( when ) import System.FilePath          ( (</>) ) import Network.URI-         ( uriScheme, uriPath )-import Data.Map-         ( Map )+         ( URI, uriScheme, uriPath ) import qualified Data.Map as Map-import GHC.Generics ( Generic )  import qualified Hackage.Security.Client                    as Sec import qualified Hackage.Security.Util.Path                 as Sec@@ -50,6 +46,7 @@ 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  -- ------------------------------------------------------------ -- * Global flags@@ -70,7 +67,8 @@     globalRequireSandbox    :: Flag Bool,     globalIgnoreSandbox     :: Flag Bool,     globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates-    globalHttpTransport     :: Flag String+    globalHttpTransport     :: Flag String,+    globalNix               :: Flag Bool  -- ^ Integrate with Nix   } deriving Generic  defaultGlobalFlags :: GlobalFlags@@ -88,7 +86,8 @@     globalRequireSandbox    = Flag False,     globalIgnoreSandbox     = Flag False,     globalIgnoreExpiry      = Flag False,-    globalHttpTransport     = mempty+    globalHttpTransport     = mempty,+    globalNix               = Flag False   }  instance Monoid GlobalFlags where@@ -219,8 +218,19 @@                -> (SecureRepo -> IO a)  -- ^ Callback                -> IO a initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do-    withRepo $ \r -> do-      requiresBootstrap <- Sec.requiresBootstrap r+    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)@@ -228,8 +238,8 @@       callback $ SecureRepo r   where     -- Initialize local or remote repo depending on the URI-    withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a-    withRepo callback | uriScheme remoteRepoURI == "file:" = do+    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@@ -237,9 +247,9 @@                                Sec.hackageIndexLayout                                logTUF                                callback-    withRepo callback =+    withRepo mirrors callback =       Sec.Remote.withRepository httpLib-                                [remoteRepoURI]+                                (remoteRepoURI:mirrors)                                 Sec.Remote.defaultRepoOpts                                 cache                                 Sec.hackageRepoLayout
Distribution/Client/Haddock.hs view
@@ -23,9 +23,9 @@ import Distribution.Package          ( packageVersion ) import Distribution.Simple.Haddock (haddockPackagePaths)-import Distribution.Simple.Program (haddockProgram, ProgramConfiguration-                                   , rawSystemProgram, requireProgramVersion)-import Distribution.Version (Version(Version), orLaterVersion)+import Distribution.Simple.Program (haddockProgram, ProgramDb+                                   , runProgram, requireProgramVersion)+import Distribution.Version (mkVersion, orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, allPackagesByName )@@ -35,17 +35,17 @@          ( InstalledPackageInfo(exposed) )  regenerateHaddockIndex :: Verbosity-                       -> InstalledPackageIndex -> ProgramConfiguration+                       -> InstalledPackageIndex -> ProgramDb                        -> FilePath                        -> IO ()-regenerateHaddockIndex verbosity pkgs conf index = do+regenerateHaddockIndex verbosity pkgs progdb index = do       (paths, warns) <- haddockPackagePaths pkgs' Nothing       let paths' = [ (interface, html) | (interface, Just html) <- paths]       forM_ warns (debug verbosity)        (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram-                                    (orLaterVersion (Version [0,6] [])) conf+                                    (orLaterVersion (mkVersion [0,6])) progdb        createDirectoryIfMissing True destDir @@ -57,7 +57,7 @@                     , "--title=Haskell modules on this system" ]                  ++ [ "--read-interface=" ++ html ++ "," ++ interface                     | (interface, html) <- paths' ]-        rawSystemProgram verbosity confHaddock flags+        runProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)         installDirectoryContents verbosity tempDir destDir
Distribution/Client/HttpUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | Separate module for HTTP actions, using a proxy server if one exists. -----------------------------------------------------------------------------@@ -14,6 +14,9 @@     isOldHackageURI   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Network.HTTP          ( Request (..), Response (..), RequestMethod (..)          , Header(..), HeaderName(..), lookupHeader )@@ -23,39 +26,36 @@ import Network.Browser          ( browse, setOutHandler, setErrHandler, setProxy          , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import qualified Control.Exception as Exception+import Control.Exception+         ( evaluate )+import Control.DeepSeq+         ( force ) import Control.Monad-         ( when, guard )+         ( guard ) import qualified Data.ByteString.Lazy.Char8 as BS-import Data.List-         ( isPrefixOf, find, intercalate )-import Data.Maybe-         ( listToMaybe, maybeToList, fromMaybe ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, info, warn, debug, notice, writeFileAtomic+         ( die', info, warn, debug, notice, writeFileAtomic          , copyFileVerbose,  withTempFile          , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Client.Utils-         ( readMaybe, withTempFileName )+         ( withTempFileName ) import Distribution.Client.Types          ( RemoteRepo(..) ) import Distribution.System          ( buildOS, buildArch ) import Distribution.Text          ( display )-import Data.Char-         ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories ) import System.FilePath          ( (<.>) ) import System.Directory          ( doesFileExist, renameFile )+import System.IO+         ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error          ( isDoesNotExistError ) import Distribution.Simple.Program@@ -70,7 +70,6 @@         ( IOEncoding(..), getEffectiveEnvironment ) import Numeric (showHex) import System.Directory (canonicalizePath)-import System.IO (hClose) import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..))@@ -132,26 +131,26 @@         304 -> do             notice verbosity "Skipping download: local and remote files match."             return FileAlreadyInCache-        errCode ->  die $ "Failed to download " ++ show uri+        errCode ->  die' verbosity $ "Failed to download " ++ show uri                        ++ " : HTTP code " ++ show errCode  ------------------------------------------------------------------------------ -- Utilities for repo url management -- -remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO ()-remoteRepoCheckHttps transport repo+remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()+remoteRepoCheckHttps verbosity transport repo   | uriScheme (remoteRepoURI repo) == "https:"   , not (transportSupportsHttps transport)-              = die $ "The remote repository '" ++ remoteRepoName repo+              = die' verbosity $ "The remote repository '" ++ remoteRepoName repo                    ++ "' specifies a URL that " ++ requiresHttpsErrorMessage   | otherwise = return () -transportCheckHttps :: HttpTransport -> URI -> IO ()-transportCheckHttps transport uri+transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()+transportCheckHttps verbosity transport uri   | uriScheme uri == "https:"   , not (transportSupportsHttps transport)-              = die $ "The URL " ++ show uri+              = die' verbosity $ "The URL " ++ show uri                    ++ " " ++ requiresHttpsErrorMessage   | otherwise = return () @@ -165,13 +164,13 @@    ++ "external program is available, or one can be selected specifically "    ++ "with the global flag --http-transport=" -remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo-remoteRepoTryUpgradeToHttps transport repo+remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo+remoteRepoTryUpgradeToHttps verbosity transport repo   | remoteRepoShouldTryHttps repo   , uriScheme (remoteRepoURI repo) == "http:"   , not (transportSupportsHttps transport)   , not (transportManuallySelected transport)-  = die $ "The builtin HTTP implementation does not support HTTPS, but using "+  = 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 ]@@ -247,7 +246,7 @@  noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)           -> IO (Int, String)-noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet"+noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"  supportedTransports :: [(String, Maybe Program, Bool,                          ProgramDb -> Maybe HttpTransport)]@@ -285,7 +284,7 @@         let Just transport = mkTrans progdb         return transport { transportManuallySelected = True } -      Nothing -> die $ "Unknown HTTP transport specified: " ++ name+      Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name                     ++ ". The supported transports are "                     ++ intercalate ", "                          [ name' | (name', _, _, _ ) <- supportedTransports ]@@ -340,9 +339,10 @@            resp <- getProgramInvocationOutput verbosity                     (programInvocation prog args)-          headers <- readFile tmpFile-          (code, _err, etag') <- parseResponse uri resp headers-          return (code, etag')+          withFile tmpFile ReadMode $ \hnd -> do+            headers <- hGetContents hnd+            (code, _err, etag') <- parseResponse verbosity uri resp headers+            evaluate $ force (code, etag')      posthttp = noPostYet @@ -367,7 +367,7 @@                    ]         resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth                   (programInvocation prog args)-        (code, err, _etag) <- parseResponse uri resp ""+        (code, err, _etag) <- parseResponse verbosity uri resp ""         return (code, err)      puthttpfile verbosity uri path auth headers = do@@ -384,12 +384,13 @@                    | Header name value <- headers ]         resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth                   (programInvocation prog args)-        (code, err, _etag) <- parseResponse uri resp ""+        (code, err, _etag) <- parseResponse verbosity uri resp ""         return (code, err) -    -- on success these curl involcations produces an output like "200"+    -- on success these curl invocations produces an output like "200"     -- and on failure it has the server error response first-    parseResponse uri resp headers =+    parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)+    parseResponse verbosity uri resp headers =       let codeerr =             case reverse (lines resp) of               (codeLine:rerrLines) ->@@ -408,16 +409,29 @@         in case codeerr of             Just (i, err) -> return (i, err, mb_etag)-            _             -> statusParseFail uri resp+            _             -> statusParseFail verbosity uri resp   wgetTransport :: ConfiguredProgram -> HttpTransport wgetTransport prog =-    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  HttpTransport gethttp posthttp posthttpfile puthttpfile True False   where-    gethttp verbosity uri etag destPath reqHeaders = do+    gethttp verbosity uri etag destPath reqHeaders =  do         resp <- runWGet verbosity uri args-        (code, etag') <- parseOutput uri resp++        -- 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 (\hdr -> isRangeHeader hdr) 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@@ -429,14 +443,22 @@                [ ["--header", "If-None-Match: " ++ t]                | t <- maybeToList etag ]             ++ [ "--header=" ++ show name ++ ": " ++ value-               | Header name value <- reqHeaders ]+               | 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+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do           hClose responseHandle           (body, boundary) <- generateMultipartBody path           BS.hPut tmpHandle body@@ -449,12 +471,14 @@                      , "--header=Content-type: multipart/form-data; " ++                                               "boundary=" ++ boundary ]           out <- runWGet verbosity (addUriAuth auth uri) args-          (code, _etag) <- parseOutput uri out-          resp <- readFile responseFile-          return (code, resp)+          (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+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do             hClose responseHandle             let args = [ "--method=PUT", "--body-file="++path                        , "--user-agent=" ++ userAgent@@ -465,9 +489,10 @@                        | Header name value <- headers ]              out <- runWGet verbosity (addUriAuth auth uri) args-            (code, _etag) <- parseOutput uri out-            resp <- readFile responseFile-            return (code, resp)+            (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@@ -490,14 +515,14 @@         -- wget returns exit code 8 for server "errors" like "304 not modified"         if exitCode == ExitSuccess || exitCode == ExitFailure 8           then return resp-          else die $ "'" ++ programPath prog+          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 uri resp =+    parseOutput verbosity uri resp =       let parsedCode = listToMaybe                      [ code                      | (protocol:codestr:_err) <- map words (reverse (lines resp))@@ -509,7 +534,7 @@                     | ["ETag:", etag] <- map words (reverse (lines resp)) ]        in case parsedCode of             Just i -> return (i, mb_etag)-            _      -> statusParseFail uri resp+            _      -> statusParseFail verbosity uri resp   powershellTransport :: ConfiguredProgram -> HttpTransport@@ -529,7 +554,7 @@       where         parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of           Just i  -> return (i, Nothing) -- TODO extract real etag-          Nothing -> statusParseFail uri x+          Nothing -> statusParseFail verbosity uri x         etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]      posthttp = noPostYet@@ -547,14 +572,14 @@         resp <- runPowershellScript verbosity $ webclientScript           (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)           (uploadFileAction "POST" uri fullPath)-        parseUploadResponse uri resp+        parseUploadResponse verbosity uri resp      puthttpfile verbosity uri path auth headers = do       fullPath <- canonicalizePath path       resp <- runPowershellScript verbosity $ webclientScript         (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)         (uploadFileAction "PUT" uri fullPath)-      parseUploadResponse uri resp+      parseUploadResponse verbosity uri resp      runPowershellScript verbosity script = do       let args =@@ -593,10 +618,10 @@       , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"       ] -    parseUploadResponse uri resp = case lines (trim resp) of+    parseUploadResponse verbosity uri resp = case lines (trim resp) of       (codeStr : message)         | Just code <- readMaybe codeStr -> return (code, unlines message)-      _ -> statusParseFail uri resp+      _ -> statusParseFail verbosity uri resp      webclientScript setup action = unlines       [ "$wc = new-object system.net.webclient;"@@ -641,6 +666,7 @@       (_, 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')@@ -689,7 +715,7 @@       p <- fixupEmptyProxy <$> fetchProxy True       Exception.handleJust         (guard . isDoesNotExistError)-        (const . die $ "Couldn't establish HTTP connection. "+        (const . die' verbosity $ "Couldn't establish HTTP connection. "                     ++ "Possible cause: HTTP proxy server is down.") $         browse $ do           setProxy p@@ -713,9 +739,9 @@                    , " (", display buildOS, "; ", display buildArch, ")"                    ] -statusParseFail :: URI -> String -> IO a-statusParseFail uri r =-    die $ "Failed to download " ++ show uri ++ " : "+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
Distribution/Client/IndexUtils.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.IndexUtils@@ -21,62 +23,74 @@   getSourcePackages,   getSourcePackagesMonitorFiles, +  IndexState(..),+  getSourcePackagesAtIndexState,+   Index(..),   PackageEntry(..),   parsePackageIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,-  readCacheStrict,+  readCacheStrict, -- only used by soon-to-be-obsolete sandbox code    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.Timestamp import Distribution.Client.Types+import Distribution.Verbosity  import Distribution.Package-         ( PackageId, PackageIdentifier(..), PackageName(..)-         , Package(..), packageVersion, packageName-         , Dependency(Dependency) )-import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex      as PackageIndex+         ( PackageId, PackageIdentifier(..), mkPackageName+         , Package(..), packageVersion, packageName )+import Distribution.Types.Dependency import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription          ( GenericPackageDescription )-import Distribution.PackageDescription.Parse-         ( parsePackageDescription ) import Distribution.Simple.Compiler          ( Compiler, PackageDBStack ) import Distribution.Simple.Program-         ( ProgramConfiguration )+         ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure          ( getInstalledPackages, getInstalledPackagesMonitorFiles )-import Distribution.ParseUtils-         ( ParseResult(..) ) import Distribution.Version-         ( Version(Version), intersectVersionRanges )+         ( mkVersion, intersectVersionRanges ) import Distribution.Text          ( display, simpleParse )-import Distribution.Verbosity-         ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8, ignoreBOM )+         ( die', warn, info ) import Distribution.Client.Setup          ( RepoContext(..) ) -import Data.Char   (isAlphaNum)-import Data.Maybe  (mapMaybe, catMaybes, maybeToList)-import Data.List   (isPrefixOf)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( parseGenericPackageDescriptionMaybe )+import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse+#else+import Distribution.ParseUtils+         ( ParseResult(..) )+import Distribution.PackageDescription.Parse+         ( parseGenericPackageDescription )+import Distribution.Simple.Utils+         ( fromUTF8, ignoreBOM )+import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse #endif++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 Control.Monad (when, liftM)-import Control.Exception (evaluate)+import Control.DeepSeq+import Control.Monad+import Control.Exception import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS@@ -84,8 +98,9 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath                                  , tryFindAddSourcePackageDesc )+import Distribution.Compat.Binary import Distribution.Compat.Exception (catchIO)-import Distribution.Client.Compat.Time (getFileAge, getModTime)+import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath          ( (</>), (<.>), takeExtension, replaceExtension, splitDirectories, normalise )@@ -100,10 +115,10 @@  -- | Reduced-verbosity version of 'Configure.getInstalledPackages' getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramConfiguration+                     -> PackageDBStack -> ProgramDb                      -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDbs conf =-    Configure.getInstalledPackages verbosity' comp packageDbs conf+getInstalledPackages verbosity comp packageDbs progdb =+    Configure.getInstalledPackages verbosity' comp packageDbs progdb   where     verbosity'  = lessVerbose verbosity @@ -128,6 +143,48 @@ -- 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 :: IndexState -> 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. --@@ -136,16 +193,70 @@ -- -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb-getSourcePackages 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."-  return SourcePackageDb {-    packageIndex       = mempty,-    packagePreferences = mempty-  }-getSourcePackages verbosity repoCtxt = do-  info verbosity "Reading available packages..."-  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)+getSourcePackages verbosity repoCtxt =+    getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead++-- | 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.+--+-- TODO: Enhance to allow specifying per-repo 'IndexState's and also+-- report back per-repo 'IndexStateInfo's (in order for @new-freeze@+-- to access it)+getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState+                           -> IO SourcePackageDb+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+      }+getSourcePackagesAtIndexState verbosity repoCtxt idxState = do+  case idxState of+      IndexStateHead      -> info verbosity "Reading available packages..."+      IndexStateTime time ->+          info verbosity ("Reading available packages (for index-state as of "+                          ++ display time ++ ")...")++  pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do+      let rname = maybe "" remoteRepoName $ maybeRepoRemote r+      unless (idxState == IndexStateHead) $+          case r of+            RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")+            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ 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("++rname++") = " +++                              display (isiHeadTime isi))+            return ()+        IndexStateTime ts0 -> do+            when (isiMaxTime isi /= ts0) $+                warn verbosity ("Requested index-state " ++ display ts0+                                ++ " does not exist in '"++rname++"'!"+                                ++ " Falling back to older state ("+                                ++ display (isiMaxTime isi) ++ ").")+            info verbosity ("index-state("++rname++") = " +++                              display (isiMaxTime isi) ++ " (HEAD = " +++                              display (isiHeadTime isi) ++ ")")++      pure (pis,deps)+   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -159,9 +270,9 @@ readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do     updateRepoIndexCache verbosity index-    cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)+    cache <- readIndexCache verbosity index     withFile (indexFile index) ReadMode $ \indexHnd ->-      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict+      packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict  -- | Read a repository index from disk, from the local file specified by -- the 'Repo'.@@ -170,13 +281,15 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> RepoContext -> Repo-              -> IO (PackageIndex SourcePackage, [Dependency])-readRepoIndex verbosity repoCtxt repo =+readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState+              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)+readRepoIndex verbosity repoCtxt repo idxState =   handleNotFound $ do     warnIfIndexIsOld =<< getIndexFileAge repo     updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)+    readPackageIndexCacheFile verbosity mkAvailablePackage+                              (RepoIndex repoCtxt repo)+                              idxState    where     mkAvailablePackage pkgEntry =@@ -201,7 +314,7 @@           RepoLocal{..}  -> warn verbosity $                "The package list for the local repo '" ++ repoLocalDir             ++ "' is missing. The repo is invalid."-        return mempty+        return (mempty,mempty,emptyStateInfo)       else ioError e      isOldThreshold = 15 --days@@ -260,8 +373,10 @@  -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef-                      deriving Eq+                      deriving (Eq,Generic) +instance Binary BuildTreeRefType+ refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t   | t == Tar.buildTreeRefTypeCode      = LinkRef@@ -295,14 +410,14 @@ -- 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 :: ByteString -> [IO (Maybe PackageOrDep)]-parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . 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 entry blockNo+          mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo           return $ fmap (fmap Pkg) mkPkgEntry          tryExtractPrefs = do@@ -321,21 +436,29 @@     go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)     go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' -extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))-extractPkg entry blockNo = case Tar.entryContent entry of+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 simpleParse vers of           Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where-              pkgid  = PackageIdentifier (PackageName pkgname) ver-              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack+              pkgid  = PackageIdentifier (mkPackageName pkgname) ver+#ifdef CABAL_PARSEC+              parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)+              descr = case parsed of+                  Just d  -> d+                  Nothing -> error $ "Couldn't read cabal file "+                                    ++ show fileName+#else+              parsed = parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack                                                $ content               descr  = case parsed of                 ParseOk _ d -> d                 _           -> error $ "Couldn't read cabal file "                                     ++ show fileName+#endif           _ -> Nothing         _ -> Nothing @@ -346,8 +469,8 @@         dirExists <- doesDirectoryExist path         result <- if not dirExists then return Nothing                   else do-                    cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index."-                    descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile+                    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@@ -390,6 +513,19 @@                    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@@ -407,12 +543,26 @@ cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index)   = index `replaceExtension` "cache" +-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)+is01Index :: Index -> Bool+is01Index (RepoIndex _ repo) = case repo of+                                 RepoSecure {} -> True+                                 RepoRemote {} -> False+                                 RepoLocal  {} -> False+is01Index (SandboxIndex _)   = False++ updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do-    info verbosity ("Updating index cache file " ++ cacheFile index)-    withIndexEntries index $ \entries -> do-      let cache = Cache { cacheEntries = entries }-      writeFile (cacheFile index) (showIndexCache cache)+    info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")+    withIndexEntries verbosity index $ \entries -> do+      let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)+          cache = Cache { cacheHeadTs  = maxTs+                        , cacheEntries = entries+                        }+      writeIndexCache index cache+      info verbosity ("Index cache updated to index-state "+                      ++ display (cacheHeadTs cache))  -- | Read the index (for the purpose of building a cache) --@@ -434,73 +584,94 @@ -- 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 :: Index -> ([IndexCacheEntry] -> IO a) -> IO a-withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =+withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a+withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback =     repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->       Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do-        let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile))-               -> IO [IndexCacheEntry]-            mk (_, _fp, Nothing) =-              return [] -- skip unrecognized file-            mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) =-              return [] -- skip metadata-            mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do-              let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry)-              return [CachePackageId pkgId blockNo]-            mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do-              content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file-              return $ map CachePreference (parsePreferredVersions content)-        entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory)-        callback $ concat entriess-withIndexEntries index callback = 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 index callback = do -- non-secure repositories     withFile (indexFile index) ReadMode $ \h -> do       bs          <- maybeDecompress `fmap` BS.hGetContents h-      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs+      pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs       callback $ map toCache (catMaybes pkgsOrPrefs)   where     toCache :: PackageOrDep -> IndexCacheEntry-    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo+    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp     toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo-    toCache (Dep d) = CachePreference d+    toCache (Dep d) = CachePreference d 0 nullTimestamp  data ReadPackageIndexMode = ReadPackageIndexStrict                           | ReadPackageIndexLazyIO  readPackageIndexCacheFile :: Package pkg-                          => (PackageEntry -> pkg)+                          => Verbosity+                          -> (PackageEntry -> pkg)                           -> Index-                          -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg index = do-  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)-  indexHnd <- openFile (indexFile index) ReadMode-  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO+                          -> IndexState+                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)+readPackageIndexCacheFile verbosity mkPkg index idxState = do+    cache0    <- readIndexCache verbosity index+    indexHnd <- openFile (indexFile index) ReadMode+    let (cache,isi) = filterCache idxState cache0+    (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO+    pure (pkgs,deps,isi) + packageIndexFromCache :: Package pkg-                      => (PackageEntry -> pkg)+                      => Verbosity+                     -> (PackageEntry -> pkg)                       -> Handle                       -> Cache                       -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache mkPkg hnd cache mode = do-     (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode+packageIndexFromCache verbosity mkPkg hnd cache mode = do+     (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode      pkgIndex <- evaluate $ PackageIndex.fromList pkgs      return (pkgIndex, prefs)  -- | Read package list ----- The result packages (though not the preferences) are guaranteed to be listed--- in the same order as they are in the tar file (because later entries in a tar--- file mask earlier ones).-packageListFromCache :: (PackageEntry -> pkg)+-- 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                      -> ReadPackageIndexMode                      -> IO ([pkg], [Dependency])-packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries+packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries   where-    accum srcpkgs prefs [] = return (reverse srcpkgs, prefs)+    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) -    accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do+    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.@@ -509,27 +680,25 @@         pkgtxt <- getEntryContent blockno         pkg    <- readPackageDescription pkgtxt         return (pkg, pkgtxt)-      let srcpkg = case mode of-            ReadPackageIndexLazyIO ->-              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)-            ReadPackageIndexStrict ->-              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg-                                            pkgtxt blockno)-      accum (srcpkg:srcpkgs) prefs entries+      case mode of+        ReadPackageIndexLazyIO -> pure ()+        ReadPackageIndexStrict -> evaluate pkg *> evaluate pkgtxt *> pure ()+      let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)+      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries -    accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do+    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 path err-                 PackageDesc.Parse.readPackageDescription normal file+                 file <- tryFindAddSourcePackageDesc verbosity path err+                 PackageDesc.Parse.readGenericPackageDescription normal file       let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)-      accum (srcpkg:srcpkgs) prefs entries+      accum srcpkgs (srcpkg:btrs) prefs entries -    accum srcpkgs prefs (CachePreference pref : entries) =-      accum srcpkgs (pref: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@@ -543,11 +712,18 @@      readPackageDescription :: ByteString -> IO GenericPackageDescription     readPackageDescription content =-      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of+#ifdef CABAL_PARSEC+      case parseGenericPackageDescriptionMaybe (BS.toStrict content) of+        Just gpd -> return gpd+        Nothing  -> interror "failed to parse .cabal file"+#else+      case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ d -> return d         _           -> interror "failed to parse .cabal file"+#endif -    interror msg = die $ "internal error when reading package index: " ++ msg+    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." @@ -555,31 +731,156 @@ -- 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)++-- | Read the 'Index' cache from the filesystem without attempting to+-- regenerate on parsing failures.+readIndexCache' :: Index -> IO (Either String Cache)+readIndexCache' index+  | is01Index index = decodeFileOrFail' (cacheFile index)+  | otherwise       = liftM (Right .read00IndexCache) $+                      BSS.readFile (cacheFile index)++-- | Write the 'Index' cache to the filesystem+writeIndexCache :: Index -> Cache -> IO ()+writeIndexCache index cache+  | is01Index index = encodeFile (cacheFile index) cache+  | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)++-- | 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]+    }++instance NFData Cache where+    rnf = rnf . cacheEntries+ -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. ---type BlockNo = Tar.TarEntryOffset+type BlockNo = Word32 -- Tar.TarEntryOffset -data IndexCacheEntry = CachePackageId PackageId BlockNo-                     | CacheBuildTreeRef BuildTreeRefType BlockNo-                     | CachePreference Dependency-  deriving (Eq) -installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String-installedUnitId = "pkg:"+data IndexCacheEntry+    = CachePackageId PackageId !BlockNo !Timestamp+    | CachePreference Dependency !BlockNo !Timestamp+    | CacheBuildTreeRef !BuildTreeRefType !BlockNo+      -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build+  deriving (Eq,Generic)++instance NFData IndexCacheEntry where+    rnf (CachePackageId pkgid _ _) = rnf pkgid+    rnf (CachePreference dep _ _) = rnf dep+    rnf (CacheBuildTreeRef _ _) = ()++cacheEntryTimestamp :: IndexCacheEntry -> Timestamp+cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp+cacheEntryTimestamp (CachePreference _ _ ts) = ts+cacheEntryTimestamp (CachePackageId _ _ ts)  = ts++----------------------------------------------------------------------------+-- new binary 01-index.cache format++instance Binary Cache where+    put (Cache headTs ents) = do+        -- magic / format version+        --+        -- NB: this currently encodes word-size implicitly; when we+        -- switch to CBOR encoding, we will have a platform+        -- independent binary encoding+        put (0xcaba1002::Word)+        put headTs+        put ents++    get = do+        magic <- get+        when (magic /= (0xcaba1002::Word)) $+            fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic)+        Cache <$> get <*> get++instance Binary IndexCacheEntry++----------------------------------------------------------------------------+-- legacy 00-index.cache format++packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+packageKey = "pkg:" blocknoKey = "b#" buildTreeRefKey     = "build-tree-ref:" preferredVersionKey = "pref-ver:" -readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry-readIndexCacheEntry = \line ->+-- 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 installedUnitId && sep == BSS.pack blocknoKey ->+      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->       case (parseName pkgnamestr, parseVer pkgverstr [],             parseBlockNo blocknostr) of         (Just pkgname, Just pkgver, Just blockno)-          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)+          -> Just (CachePackageId (PackageIdentifier pkgname pkgver)+                                  blockno nullTimestamp)         _ -> Nothing     [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->       case (parseRefType typecodestr, parseBlockNo blocknostr) of@@ -587,13 +888,15 @@           -> Just (CacheBuildTreeRef refType blockno)         _ -> Nothing -    (key: remainder) | key == BSS.pack preferredVersionKey ->-      fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))+    (key: remainder) | key == BSS.pack preferredVersionKey -> do+      pref <- simpleParse (BSS.unpack (BSS.unwords remainder))+      return $ CachePreference pref 0 nullTimestamp+     _  -> Nothing   where     parseName str       | BSS.all (\c -> isAlphaNum c || c == '-') str-                  = Just (PackageName (BSS.unpack str))+                  = Just (mkPackageName (BSS.unpack str))       | otherwise = Nothing      parseVer str vs =@@ -602,7 +905,7 @@         Just (v, str') -> case BSS.uncons str' of           Just ('.', str'') -> parseVer str'' (v:vs)           Just _            -> Nothing-          Nothing           -> Just (Version (reverse (v:vs)) [])+          Nothing           -> Just (mkVersion (reverse (v:vs)))      parseBlockNo str =       case BSS.readInt str of@@ -617,31 +920,22 @@             -> Just (refTypeFromTypeCode typeCode)         _   -> Nothing -showIndexCacheEntry :: IndexCacheEntry -> String-showIndexCacheEntry entry = unwords $ case entry of-   CachePackageId pkgid b -> [ installedUnitId-                             , display (packageName pkgid)-                             , display (packageVersion pkgid)-                             , blocknoKey-                             , show b-                             ]-   CacheBuildTreeRef t b  -> [ buildTreeRefKey-                             , [typeCodeFromRefType t]-                             , show b-                             ]-   CachePreference dep    -> [ preferredVersionKey-                             , display dep-                             ]---- | Cabal caches various information about the Hackage index-data Cache = Cache {-    cacheEntries :: [IndexCacheEntry]-  }--readIndexCache :: BSS.ByteString -> Cache-readIndexCache bs = Cache {-    cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs-  }+-- legacy 00-index.cache format+show00IndexCache :: Cache -> String+show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries -showIndexCache :: Cache -> String-showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries+show00IndexCacheEntry :: IndexCacheEntry -> String+show00IndexCacheEntry entry = unwords $ case entry of+   CachePackageId pkgid b _ -> [ packageKey+                               , display (packageName pkgid)+                               , display (packageVersion pkgid)+                               , blocknoKey+                               , show b+                               ]+   CacheBuildTreeRef tr b   -> [ buildTreeRefKey+                               , [typeCodeFromRefType tr]+                               , show b+                               ]+   CachePreference dep _ _  -> [ preferredVersionKey+                               , display dep+                               ]
+ Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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++    , IndexState(..)+    ) where++import qualified Codec.Archive.Tar.Entry    as Tar+import           Control.DeepSeq+import           Control.Monad+import           Data.Char                  (isDigit)+import           Data.Int                   (Int64)+import           Data.Time                  (UTCTime (..), fromGregorianValid,+                                             makeTimeOfDayValid, showGregorian,+                                             timeOfDayToTime, timeToTimeOfDay)+import           Data.Time.Clock.POSIX      (posixSecondsToUTCTime,+                                             utcTimeToPOSIXSeconds)+import           Distribution.Compat.Binary+import qualified Distribution.Compat.ReadP  as ReadP+import           Distribution.Text+import qualified Text.PrettyPrint           as Disp+import           GHC.Generics (Generic)++-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).+newtype Timestamp = TS Int64 -- Tar.EpochTime+                  deriving (Eq,Ord,Enum,NFData,Show)++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 where+    put (TS t) = put t+    get = TS `fmap` get++instance Text Timestamp where+    disp = Disp.text . showTimestamp++    parse = parsePosix ReadP.+++ parseUTC+      where+        -- | Parses unix timestamps, e.g. @"\@1474626019"@+        parsePosix = do+            _ <- ReadP.char '@'+            t <- parseInteger+            maybe ReadP.pfail 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+            _ <- ReadP.char '-'+            mo   <- parseTwoDigits+            _ <- ReadP.char '-'+            da   <- parseTwoDigits+            _ <- ReadP.char 'T'++            utctDay <- maybe ReadP.pfail return $+                       fromGregorianValid ye mo da++            ho   <- parseTwoDigits+            _ <- ReadP.char ':'+            mi   <- parseTwoDigits+            _ <- ReadP.char ':'+            se   <- parseTwoDigits+            _ <- ReadP.char 'Z'++            utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $+                           makeTimeOfDayValid ho mi (realToFrac (se::Int))++            maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})++        parseTwoDigits = do+            d1 <- ReadP.satisfy isDigit+            d2 <- ReadP.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 <- ReadP.option ' ' (ReadP.char '-')+            ds <- ReadP.munch1 isDigit+            when (length ds < 4) ReadP.pfail+            return (read (sign:ds))++        parseInteger = do+            sign <- ReadP.option ' ' (ReadP.char '-')+            ds <- ReadP.munch1 isDigit+            return (read (sign:ds) :: Integer)++-- | Special timestamp value to be used when 'timestamp' is+-- missing/unknown/invalid+nullTimestamp :: Timestamp+nullTimestamp = TS minBound++----------------------------------------------------------------------------+-- defined here for now to avoid import cycles++-- | Specification of the state of a specific repo package index+data IndexState = IndexStateHead -- ^ Use all available entries+                | IndexStateTime !Timestamp -- ^ Use all entries that existed at+                                            -- the specified time+                deriving (Eq,Generic,Show)++instance Binary IndexState+instance NFData IndexState++instance Text IndexState where+    disp IndexStateHead = Disp.text "HEAD"+    disp (IndexStateTime ts) = disp ts++    parse = parseHead ReadP.+++ parseTime+      where+        parseHead = do+            _ <- ReadP.string "HEAD"+            return IndexStateHead++        parseTime = IndexStateTime `fmap` parse
Distribution/Client/Init.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init@@ -23,48 +22,40 @@    ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)+ import System.IO   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory   ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile   , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath-  ( (</>), (<.>), takeBaseName )+  ( (</>), (<.>), takeBaseName, equalFilePath ) import Data.Time   ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import Data.Char-  ( toUpper ) import Data.List-  ( intercalate, nub, groupBy, (\\) )-import Data.Maybe-  ( fromMaybe, isJust, catMaybes, listToMaybe )+  ( groupBy, (\\) ) import Data.Function   ( on ) import qualified Data.Map as M-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-  ( (<$>) )-import Data.Traversable-  ( traverse )-#endif import Control.Monad-  ( when, unless, (>=>), join, forM_ )+  ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow   ( (&&&), (***) )  import Text.PrettyPrint hiding (mode, cat) -import Data.Version-  ( Version(..) ) import Distribution.Version-  ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )+  ( Version, mkVersion, alterVersion+  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity   ( Verbosity ) import Distribution.ModuleName-  ( ModuleName, fromString )  -- And for the Text instance+  ( ModuleName )  -- And for the Text instance import Distribution.InstalledPackageInfo-  ( InstalledPackageInfo, sourcePackageId, exposed )+  ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P import Language.Haskell.Extension ( Language(..) ) @@ -89,14 +80,15 @@ import Distribution.Simple.Compiler   ( PackageDBStack, Compiler ) import Distribution.Simple.Program-  ( ProgramConfiguration )+  ( ProgramDb ) import Distribution.Simple.PackageIndex   ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text   ( display, Text(..) ) -import Distribution.Client.PackageIndex+import Distribution.Solver.Types.PackageIndex   ( elemByPackageName )+ import Distribution.Client.IndexUtils   ( getSourcePackages ) import Distribution.Client.Types@@ -108,12 +100,12 @@           -> PackageDBStack           -> RepoContext           -> Compiler-          -> ProgramConfiguration+          -> ProgramDb           -> InitFlags           -> IO ()-initCabal verbosity packageDBs repoCtxt comp conf initFlags = do+initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do -  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb   sourcePkgDb <- getSourcePackages verbosity repoCtxt    hSetBuffering stdout NoBuffering@@ -202,7 +194,7 @@ --  if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do-  let v = Just $ Version [0,1,0,0] []+  let v = Just $ mkVersion [0,1,0,0]   v' <-     return (flagToMaybe $ version flags)         ?>> maybePrompt flags (prompt "Package version" v)         ?>> return v@@ -380,14 +372,21 @@              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 -  -- TODO: really should use guessed source roots.-  sourceFiles <- scanForModules dir+  sourceFiles0 <- scanForModules dir +  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0+   Just mods <-      return (exposedModules flags)            ?>> (return . Just . map moduleName $ sourceFiles) @@ -455,7 +454,7 @@                   message flags "You will need to pick one and manually add it to the Build-depends: field."                   return Nothing   where-    pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)+    pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps)      -- Given a list of available versions of the same package, pick a dependency.     toDep :: [P.PackageIdentifier] -> IO P.Dependency@@ -477,11 +476,11 @@ pvpize v = orLaterVersion v'            `intersectVersionRanges`            earlierVersion (incVersion 1 v')-  where v' = (v { versionBranch = take 2 (versionBranch v) })+  where v' = alterVersion (take 2) v  -- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version-incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags+incVersion n = alterVersion (incVersion' n)   where     incVersion' 0 []     = [1]     incVersion' 0 (v:_)  = [v+1]@@ -603,11 +602,6 @@                                   = return . Right $ choices !! (n-1)                    | otherwise    = Left `fmap` promptStr "Please specify" Nothing -readMaybe :: (Read a) => String -> Maybe a-readMaybe s = case reads s of-                [(a,"")] -> Just a-                _        -> Nothing- --------------------------------------------------------------------------- --  File generation  ------------------------------------------------------ ---------------------------------------------------------------------------@@ -625,28 +619,28 @@           Flag BSD3             -> Just $ bsd3 authors year -          Flag (GPL (Just (Version {versionBranch = [2]})))+          Flag (GPL (Just v)) | v == mkVersion [2]             -> Just gplv2 -          Flag (GPL (Just (Version {versionBranch = [3]})))+          Flag (GPL (Just v)) | v == mkVersion [3]             -> Just gplv3 -          Flag (LGPL (Just (Version {versionBranch = [2, 1]})))+          Flag (LGPL (Just v)) | v == mkVersion [2,1]             -> Just lgpl21 -          Flag (LGPL (Just (Version {versionBranch = [3]})))+          Flag (LGPL (Just v)) | v == mkVersion [3]             -> Just lgpl3 -          Flag (AGPL (Just (Version {versionBranch = [3]})))+          Flag (AGPL (Just v)) | v == mkVersion [3]             -> Just agplv3 -          Flag (Apache (Just (Version {versionBranch = [2, 0]})))+          Flag (Apache (Just v)) | v == mkVersion [2,0]             -> Just apache20            Flag MIT             -> Just $ mit authors year -          Flag (MPL (Version {versionBranch = [2, 0]}))+          Flag (MPL v) | v == mkVersion [2,0]             -> Just mpl20            Flag ISC@@ -850,7 +844,7 @@                 (Just "Extra files to be distributed with the package, such as examples or a README.")                 True -       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,10] []))+       , field  "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10]))                 (Just "Constraint on the version of Cabal needed to build this package.")                 False @@ -924,9 +918,9 @@                         (True, _, _)      -> (showComment com $$) . ($$ text "")                         (False, _, _)     -> ($$ text "")                       $-                      comment f <> text s <> colon-                                <> text (replicate (20 - length s) ' ')-                                <> text (fromMaybe "" . flagToMaybe $ f)+                      comment f <<>> text s <<>> colon+                                <<>> text (replicate (20 - length s) ' ')+                                <<>> text (fromMaybe "" . flagToMaybe $ f)    comment NoFlag    = text "-- "    comment (Flag "") = text "-- "    comment _         = text ""
Distribution/Client/Init/Heuristics.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Heuristics@@ -20,32 +19,31 @@     guessAuthorNameMail,     knownCategories, ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Text         (simpleParse) import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName     ( ModuleName, toFilePath )-import Distribution.Client.PackageIndex-    ( allPackagesByName ) import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD     ( category, packageDescription )-import Distribution.Simple.Utils-         ( intercalate ) import Distribution.Client.Utils          ( tryCanonicalizePath ) import Language.Haskell.Extension ( Extension ) -import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ( pure, (<$>), (<*>) )-import Data.Monoid         ( mempty, mappend, mconcat )-#endif-import Control.Arrow ( first )-import Control.Monad ( liftM )-import Data.Char   ( isAlphaNum, isNumber, isUpper, isLower, isSpace )+import Distribution.Solver.Types.PackageIndex+    ( allPackagesByName )+import Distribution.Solver.Types.SourcePackage+    ( packageDescription )++import Distribution.Client.Types ( SourcePackageDb(..) )+import Control.Monad ( mapM )+import Data.Char   ( isNumber, isLower ) import Data.Either ( partitionEithers )-import Data.List   ( isInfixOf, isPrefixOf, isSuffixOf, sortBy )-import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )+import Data.List   ( isInfixOf ) import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList ) import System.Directory ( getCurrentDirectory, getDirectoryContents,@@ -88,7 +86,7 @@  -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName-guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)+guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories)                  . tryCanonicalizePath   where     -- Treat each span of non-alphanumeric characters as a hyphen. Each@@ -251,7 +249,11 @@ -- Ordered in increasing preference, since Flag-as-monoid is identical to -- Last. authorGuessPure :: AuthorGuessIO -> AuthorGuess-authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal)+authorGuessPure (AuthorGuessIO { authorGuessEnv = env+                               , authorGuessLocalDarcs = darcsLocalF+                               , authorGuessGlobalDarcs = darcsGlobalF+                               , authorGuessLocalGit = gitLocal+                               , authorGuessGlobalGit = gitGlobal })     = mconcat         [ emailEnv env         , gitGlobal@@ -275,12 +277,13 @@ type AuthorGuess   = (Flag String, Flag String) type Enviro        = [(String, String)] data GitLoc        = Local | Global-data AuthorGuessIO = AuthorGuessIO-    Enviro         -- ^ Environment lookup table-    (Maybe String) -- ^ Contents of local darcs author info-    (Maybe String) -- ^ Contents of global darcs author info-    AuthorGuess    -- ^ Git config --local-    AuthorGuess    -- ^ Git config --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"
Distribution/Client/Init/Types.hs view
@@ -18,6 +18,7 @@ import Distribution.Simple.Setup   ( Flag(..) ) +import Distribution.Types.Dependency as P import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity@@ -82,7 +83,7 @@  instance Text PackageType where   disp = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse  instance Monoid InitFlags where   mempty = gmempty@@ -114,5 +115,5 @@  instance Text Category where   disp  = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse
Distribution/Client/Install.hs view
@@ -29,14 +29,13 @@     pruneInstallPlan   ) where -import Data.Foldable-         ( traverse_ )+import Prelude ()+import Distribution.Client.Compat.Prelude+ import Data.List-         ( isPrefixOf, unfoldr, nub, sort, (\\) )+         ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S-import Data.Maybe-         ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe ) import Control.Exception as Exception          ( Exception(toException), bracket, catches          , Handler(Handler), handleJust, IOException, SomeException )@@ -48,17 +47,12 @@          ( ExitCode(..) ) import Distribution.Compat.Exception          ( catchIO, catchExit )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-         ( (<$>) )-import Data.Traversable-         ( traverse )-#endif import Control.Monad-         ( filterM, forM_, when, unless )+         ( forM_, mapM ) import System.Directory          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,-           createDirectoryIfMissing, removeFile, renameDirectory )+           createDirectoryIfMissing, removeFile, renameDirectory,+           getDirectoryContents ) import System.FilePath          ( (</>), (<.>), equalFilePath, takeDirectory ) import System.IO@@ -71,15 +65,18 @@          ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types-         ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) )+         ( 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-         ( getSourcePackages, getInstalledPackages )+         ( getSourcePackagesAtIndexState, IndexState(..), 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@@ -102,29 +99,33 @@          ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink          ( symlinkBinaries )-import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl-import qualified Distribution.Client.ComponentDeps as CD +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 (ProgramConfiguration,-                                    defaultProgramConfiguration)+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.LocalBuildInfo (ComponentName(CLibName))-import qualified Distribution.Simple.Configure as Configure import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags-         , AllowNewer(..)+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..)          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal          ( Flag(..)@@ -132,41 +133,42 @@          , registerCommand, RegisterFlags(..), emptyRegisterFlags          , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, rawSystemExit, comparing-         , writeFileAtomic, withTempFile , withUTF8FileContents )+         ( createDirectoryIfMissingVerbose, comparing+         , writeFileAtomic, withUTF8FileContents ) 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(..)-         , Dependency(..), thisPackageVersion-         , UnitId(..), mkUnitId-         , HasUnitId(..) )+         , Package(..), HasMungedPackageId(..), HasUnitId(..)+         , UnitId )+import Distribution.Types.Dependency+         ( Dependency(..), thisPackageVersion )+import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)-         , FlagName(..), FlagAssignment )+         , FlagAssignment, showFlagValue ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Client.PkgConfigDb-         ( PkgConfigDb, readPkgConfigDb )+         ( finalizePD ) import Distribution.ParseUtils          ( showPWarning ) import Distribution.Version          ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils-         ( notice, info, warn, debug, debugNoWrap, die-         , intercalate, withTempDirectory )+         ( notice, info, warn, debug, debugNoWrap, die'+         , withTempDirectory ) import Distribution.Client.Utils-         ( determineNumJobs, inDir, logDirChange, mergeBy, MergeResult(..)+         ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)          , tryCanonicalizePath ) import Distribution.System          ( Platform, OS(Windows), buildOS ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, normal, verbose )+         ( Verbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension )  --TODO:@@ -193,7 +195,7 @@   -> RepoContext   -> Compiler   -> Platform-  -> ProgramConfiguration+  -> ProgramDb   -> UseSandbox   -> Maybe SandboxPackageInfo   -> GlobalFlags@@ -203,10 +205,22 @@   -> HaddockFlags   -> [UserTarget]   -> IO ()-install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo+install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo   globalFlags configFlags configExFlags installFlags haddockFlags   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)+                     || isUseSandbox useSandbox+    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@@ -214,16 +228,16 @@     case planResult of         Left message -> do             reportPlanningFailure verbosity args installContext message-            die' message+            die'' message         Right installPlan ->             processInstallPlan verbosity args installContext installPlan   where     args :: InstallArgs-    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,-            globalFlags, configFlags, configExFlags, installFlags,-            haddockFlags)+    args = (packageDBs, repos, comp, platform, progdb, useSandbox,+            mSandboxPkgInfo, globalFlags, configFlags, configExFlags,+            installFlags, haddockFlags) -    die' message = die (message ++ if isUseSandbox useSandbox+    die'' message = die' verbosity (message ++ if isUseSandbox useSandbox                                    then installFailedInSandbox else [])     -- TODO: use a better error message, remove duplication.     installFailedInSandbox =@@ -237,7 +251,7 @@ -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( InstalledPackageIndex, SourcePackageDb                       , PkgConfigDb-                      , [UserTarget], [PackageSpecifier SourcePackage]+                      , [UserTarget], [PackageSpecifier UnresolvedSourcePackage]                       , HttpTransport )  -- TODO: Make InstallArgs a proper data type with documented fields or just get@@ -247,7 +261,7 @@                    , RepoContext                    , Compiler                    , Platform-                   , ProgramConfiguration+                   , ProgramDb                    , UseSandbox                    , Maybe SandboxPackageInfo                    , GlobalFlags@@ -260,13 +274,16 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]                       -> IO InstallContext makeInstallContext verbosity-  (packageDBs, repoCtxt, comp, _, conf,_,_,-   globalFlags, _, configExFlags, _, _) mUserTargets = do+  (packageDBs, repoCtxt, comp, _, progdb,_,_,+   globalFlags, _, configExFlags, installFlags, _) mUserTargets = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity conf+    let idxState = fromFlagOrDefault IndexStateHead $+                       installIndexState installFlags +    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb+     checkConfigExFlags verbosity installedPkgIndex                        (packageIndex sourcePkgDb) configExFlags     transport <- repoContextGetTransport repoCtxt@@ -294,7 +311,7 @@  -- | Make an install plan given install context and install arguments. makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                -> IO (Progress String String InstallPlan)+                -> IO (Progress String String SolverInstallPlan) makeInstallPlan verbosity   (_, _, comp, platform, _, _, mSandboxPkgInfo,    _, configFlags, configExFlags, installFlags,@@ -305,34 +322,37 @@     solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))               (compilerInfo comp)     notice verbosity "Resolving dependencies..."-    return $ planPackages comp platform mSandboxPkgInfo solver-      configFlags configExFlags installFlags-      installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers+    return $ planPackages verbosity comp platform mSandboxPkgInfo solver+          configFlags configExFlags installFlags+          installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers  -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                   -> InstallPlan+                   -> SolverInstallPlan                    -> IO () processInstallPlan verbosity-  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)+  args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _)   (installedPkgIndex, sourcePkgDb, _,-   userTargets, pkgSpecifiers, _) installPlan = do+   userTargets, pkgSpecifiers, _) installPlan0 = do+     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers      unless (dryRun || nothingToInstall) $ do-      installPlan' <- performInstallations verbosity-                      args installedPkgIndex installPlan-      postInstallActions verbosity args userTargets installPlan'+      buildOutcomes <- performInstallations verbosity+                         args installedPkgIndex installPlan+      postInstallActions verbosity args userTargets installPlan buildOutcomes   where+    installPlan = InstallPlan.configureInstallPlan configFlags installPlan0     dryRun = fromFlag (installDryRun installFlags)-    nothingToInstall = null (InstallPlan.ready installPlan)+    nothingToInstall = null (fst (InstallPlan.ready installPlan))  -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ -planPackages :: Compiler+planPackages :: Verbosity+             -> Compiler              -> Platform              -> Maybe SandboxPackageInfo              -> Solver@@ -342,9 +362,9 @@              -> InstalledPackageIndex              -> SourcePackageDb              -> PkgConfigDb-             -> [PackageSpecifier SourcePackage]-             -> Progress String String InstallPlan-planPackages comp platform mSandboxPkgInfo solver+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> Progress String String SolverInstallPlan+planPackages verbosity comp platform mSandboxPkgInfo solver              configFlags configExFlags installFlags              installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = @@ -365,15 +385,22 @@        . setReorderGoals reorderGoals +      . setCountConflicts countConflicts+       . setAvoidReinstalls avoidReinstalls        . setShadowPkgs shadowPkgs        . setStrongFlags strongFlags +      . setAllowBootLibInstalls allowBootLibInstalls++      . setSolverVerbosity verbosity+       . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected) +      . removeLowerBounds allowOlder       . removeUpperBounds allowNewer        . addPreferences@@ -389,16 +416,18 @@       . addConstraints           --FIXME: this just applies all flags to all targets which           -- is silly. We should check if the flags are appropriate-          [ let pc = PackageConstraintFlags-                     (pkgSpecifierTarget pkgSpecifier) flags+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyFlags flags)             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | let flags = configConfigurationsFlags configFlags           , not (null flags)           , pkgSpecifier <- pkgSpecifiers ]        . addConstraints-          [ let pc = PackageConstraintStanzas-                     (pkgSpecifierTarget pkgSpecifier) stanzas+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyStanzas stanzas)             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | pkgSpecifier <- pkgSpecifiers ] @@ -406,6 +435,10 @@        . (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 @@ -417,28 +450,33 @@     reinstall        = fromFlag (installOverrideReinstall installFlags) ||                        fromFlag (installReinstall         installFlags)     reorderGoals     = fromFlag (installReorderGoals      installFlags)+    countConflicts   = fromFlag (installCountConflicts    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)     upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)     onlyDeps         = fromFlag (installOnlyDeps          installFlags)-    allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)+    allowOlder       = fromMaybe (AllowOlder RelaxDepsNone)+                                 (configAllowOlder configFlags)+    allowNewer       = fromMaybe (AllowNewer RelaxDepsNone)+                                 (configAllowNewer configFlags)  -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg                  => [PackageSpecifier targetpkg]-                 -> InstallPlan-                 -> Progress String String InstallPlan+                 -> 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-  . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)+  . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)   where-    explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String+    explain :: [SolverInstallPlan.SolverPlanProblem] -> String     explain problems =       "Cannot select only the dependencies (as requested by the "       ++ "'--only-dependencies' flag), "@@ -450,7 +488,7 @@       where         pkgids =           nub [ depid-              | InstallPlan.PackageMissingDeps _ depids <- problems+              | SolverInstallPlan.PackageMissingDeps _ depids <- problems               , depid <- depids               , packageName depid `elem` targetnames ] @@ -467,7 +505,7 @@                -> InstallPlan                -> SourcePackageDb                -> InstallFlags-               -> [PackageSpecifier SourcePackage]+               -> [PackageSpecifier UnresolvedSourcePackage]                -> IO () checkPrintPlan verbosity installed installPlan sourcePkgDb   installFlags pkgSpecifiers = do@@ -486,9 +524,15 @@        : map (display . packageId) preExistingTargets       ++ ["Use --reinstall if you want to reinstall anyway."] -  let lPlan = linearizeInstallPlan installed installPlan+  let lPlan =+        [ (pkg, status)+        | pkg <- InstallPlan.executionOrder installPlan+        , let status = packageStatus installed pkg ]   -- Are any packages classified as reinstalls?-  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan+  let reinstalledPkgs =+        [ ipkg+        | (_pkg, status) <- lPlan+        , ipkg <- extractReinstalls status ]   -- Packages that are already broken.   let oldBrokenPkgs =           map Installed.installedUnitId@@ -521,9 +565,9 @@   when containsReinstalls $ do     if breaksPkgs       then do-        (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $+        (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $             "The following packages are likely to be broken by the reinstalls:"-          : map (display . Installed.sourcePackageId) newBrokenPkgs+          : map (display . mungedId) newBrokenPkgs           ++ if overrideReinstall                then if dryRun then [] else                  ["Continuing even though " ++@@ -537,54 +581,28 @@   -- are already fetched.   let offline = fromFlagOrDefault False (installOfflineMode installFlags)   when offline $ do-    let pkgs = [ sourcePkg-               | InstallPlan.Configured (ConfiguredPackage sourcePkg _ _ _)-                 <- InstallPlan.toList installPlan ]+    let pkgs = [ confPkgSource cpkg+               | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]     notFetched <- fmap (map packageInfoId)                   . filterM (fmap isNothing . checkFetched . packageSource)                   $ pkgs     unless (null notFetched) $-      die $ "Can't download packages in offline mode. "+      die' verbosity $ "Can't download packages in offline mode. "       ++ "Must download the following packages to proceed:\n"       ++ intercalate ", " (map display notFetched)       ++ "\nTry using 'cabal fetch'."    where-    nothingToInstall = null (InstallPlan.ready installPlan)+    nothingToInstall = null (fst (InstallPlan.ready installPlan))      dryRun            = fromFlag (installDryRun            installFlags)     overrideReinstall = fromFlag (installOverrideReinstall installFlags) ---TODO: this type is too specific-linearizeInstallPlan :: InstalledPackageIndex-                     -> InstallPlan-                     -> [(ReadyPackage, PackageStatus)]-linearizeInstallPlan installedPkgIndex plan =-    unfoldr next plan-  where-    next plan' = case InstallPlan.ready plan' of-      []      -> Nothing-      (pkg:_) -> Just ((pkg, status), plan'')-        where-          pkgid  = installedUnitId pkg-          status = packageStatus installedPkgIndex pkg-          ipkg   = Installed.emptyInstalledPackageInfo {-                     Installed.sourcePackageId    = packageId pkg,-                     Installed.installedUnitId = pkgid-                   }-          plan'' = InstallPlan.completed pkgid (Just ipkg)-                     (BuildOk DocsNotTried TestsNotTried (Just ipkg))-                     (InstallPlan.processing [pkg] plan')-          --FIXME: This is a bit of a hack,-          -- pretending that each package is installed-          -- It's doubly a hack because the installed package ID-          -- didn't get updated...- data PackageStatus = NewPackage                    | NewVersion [Version]                    | Reinstall  [UnitId] [PackageChange] -type PackageChange = MergeResult PackageIdentifier PackageIdentifier+type PackageChange = MergeResult MungedPackageId MungedPackageId  extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids@@ -597,8 +615,8 @@   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of     [] -> NewPackage-    ps ->  case filter ((== packageId cpkg)-                        . Installed.sourcePackageId) (concatMap snd ps) of+    ps ->  case filter ((== mungedId cpkg)+                        . mungedId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)       pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)                                 (changes pkg cpkg)@@ -607,20 +625,20 @@      changes :: Installed.InstalledPackageInfo             -> ReadyPackage-            -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' = filter changed $-      mergeBy (comparing packageName)+            -> [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] -> [PackageIdentifier]+    resolveInstalledIds :: [UnitId] -> [MungedPackageId]     resolveInstalledIds =         nub       . sort-      . map Installed.sourcePackageId+      . map mungedId       . catMaybes       . map (PackageIndex.lookupUnitId installedPkgIndex) @@ -635,7 +653,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of   []   -> return ()   pkgs-    | verbosity >= Verbosity.verbose -> putStr $ unlines $+    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $         ("In order, the following " ++ wouldWill ++ " be installed:")       : map showPkgAndReason pkgs     | otherwise -> notice verbosity $ unlines $@@ -649,10 +667,10 @@     showPkg (pkg, _) = display (packageId pkg) ++                        showLatest (pkg) -    showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') +++    showPkgAndReason (ReadyPackage pkg', pr) = display (packageId pkg') ++           showLatest pkg' ++           showFlagAssignment (nonDefaultFlags pkg') ++-          showStanzas (stanzas pkg') +++          showStanzas (confPkgStanzas pkg') ++           showDep pkg' ++           case pr of             NewPackage     -> " (new package)"@@ -680,30 +698,23 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment-    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+    nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment+    nonDefaultFlags cpkg =       let defaultAssignment =             toFlagAssignment-             (genPackageFlags (Source.packageDescription spkg))-      in  fa \\ defaultAssignment--    stanzas :: ConfiguredPackage -> [OptionalStanza]-    stanzas (ConfiguredPackage _ _ sts _) = sts+             (genPackageFlags (SourcePackage.packageDescription $+                               confPkgSource cpkg))+      in  confPkgFlags cpkg \\ defaultAssignment      showStanzas :: [OptionalStanza] -> String-    showStanzas = concatMap ((' ' :) . showStanza)-    showStanza TestStanzas  = "*test"-    showStanza BenchStanzas = "*bench"+    showStanzas = concatMap ((" *" ++) . showStanza)      showFlagAssignment :: FlagAssignment -> String     showFlagAssignment = concatMap ((' ' :) . showFlagValue)-    showFlagValue (f, True)   = '+' : showFlagName f-    showFlagValue (f, False)  = '-' : showFlagName f-    showFlagName (FlagName f) = f      change (OnlyInLeft pkgid)        = display pkgid ++ " removed"     change (InBoth     pkgid pkgid') = display pkgid ++ " -> "-                                    ++ display (packageVersion pkgid')+                                    ++ display (mungedVersion pkgid')     change (OnlyInRight      pkgid') = display pkgid' ++ " added"      showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps@@ -711,9 +722,10 @@                 | otherwise = ""      revDepGraphEdges :: [(PackageId, PackageId)]-    revDepGraphEdges = [ (rpid, packageId pkg)-                       | (pkg@(ReadyPackage _ deps), _) <- plan-                       , rpid <- Installed.sourcePackageId <$> CD.flatDeps deps ]+    revDepGraphEdges = [ (rpid, packageId cpkg)+                       | (ReadyPackage cpkg, _) <- plan+                       , ConfiguredId rpid (Just PackageDescription.CLibName) _+                        <- CD.flatDeps (confPkgDeps cpkg) ]      revDeps :: Map.Map PackageId [PackageId]     revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)@@ -776,8 +788,8 @@ theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec =   case pkgSpec of-    NamedPackage name [PackageConstraintVersion name' version]-      | name == name' -> PackageIdentifier name <$> trivialRange version+    NamedPackage name [PackagePropertyVersion version]+      -> PackageIdentifier name <$> trivialRange version     NamedPackage _ _ -> Nothing     SpecificSourcePackage pkg -> Just $ packageId pkg   where@@ -804,11 +816,12 @@                    -> InstallArgs                    -> [UserTarget]                    -> InstallPlan+                   -> BuildOutcomes                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo+  (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo   ,globalFlags, configFlags, _, installFlags, _)-  targets installPlan = do+  targets installPlan buildOutcomes = do    unless oneShot $     World.insert verbosity worldFile@@ -817,7 +830,7 @@       | UserTargetNamed dep <- targets ]    let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)-                                                  installPlan+                                                  installPlan buildOutcomes   BuildReports.storeLocal (compilerInfo comp)                           (fromNubList $ installSummaryFile installFlags)                           buildReports@@ -827,15 +840,16 @@   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox-                         configFlags installFlags installPlan+  regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+                         configFlags installFlags buildOutcomes -  symlinkBinaries verbosity platform comp configFlags installFlags installPlan+  symlinkBinaries verbosity platform comp configFlags installFlags+                  installPlan buildOutcomes -  printBuildFailures installPlan+  printBuildFailures verbosity buildOutcomes -  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo-                              comp platform installPlan+  updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo+                              comp platform installPlan buildOutcomes    where     reportingLevel = fromFlag (installBuildReports installFlags)@@ -881,14 +895,14 @@                        -> [PackageDB]                        -> Compiler                        -> Platform-                       -> ProgramConfiguration+                       -> ProgramDb                        -> UseSandbox                        -> ConfigFlags                        -> InstallFlags-                       -> InstallPlan+                       -> BuildOutcomes                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox-                       configFlags installFlags installPlan+regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox+                       configFlags installFlags buildOutcomes   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do    defaultDirs <- InstallDirs.defaultInstallDirs@@ -902,8 +916,8 @@      "Updating documentation index " ++ indexFile    --TODO: might be nice if the install plan gave us the new InstalledPackageInfo-  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile    | otherwise = return ()   where@@ -916,14 +930,14 @@     -- #1337), we don't do it for global installs or special cases where we're     -- installing into a specific db.     shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall)-                                && someDocsWereInstalled installPlan+                                && someDocsWereInstalled buildOutcomes       where-        someDocsWereInstalled = any installedDocs . InstallPlan.toList+        someDocsWereInstalled = any installedDocs . Map.elems+        installedDocs (Right (BuildResult DocsOk _ _)) = True+        installedDocs _                                = False+         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs--        installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True-        installedDocs _                                                = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False @@ -945,24 +959,26 @@                 -> ConfigFlags                 -> InstallFlags                 -> InstallPlan+                -> BuildOutcomes                 -> IO ()-symlinkBinaries verbosity platform comp configFlags installFlags plan = do+symlinkBinaries verbosity platform comp configFlags installFlags+                plan buildOutcomes = do   failed <- InstallSymlink.symlinkBinaries platform comp                                            configFlags installFlags-                                           plan+                                           plan buildOutcomes   case failed of     [] -> return ()     [(_, exe, path)] ->       warn verbosity $            "could not create a symlink in " ++ bindir ++ " for "-        ++ exe ++ " because the file exists there already but is not "+        ++ display 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 ", " [ exe | (_, exe, _) <- exes ]+        ++ intercalate ", " [ display 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 "@@ -971,16 +987,15 @@     bindir = fromFlag (installSymlinkBinDir installFlags)  -printBuildFailures :: InstallPlan-                   -> IO ()-printBuildFailures plan =-  case [ (pkg, reason)-       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of+printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()+printBuildFailures verbosity buildOutcomes =+  case [ (pkgid, failure)+       | (pkgid, Left failure) <- Map.toList buildOutcomes ] of     []     -> return ()-    failed -> die . unlines+    failed -> die' verbosity . unlines             $ "Error: some packages failed to install:"-            : [ display (packageId pkg) ++ printFailureReason reason-              | (pkg, reason) <- failed ]+            : [ display pkgid ++ printFailureReason reason+              | (pkgid, reason) <- failed ]   where     printFailureReason reason = case reason of       DependentFailed pkgid -> " depends on " ++ display pkgid@@ -1015,31 +1030,35 @@  -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps.-updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo+updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo                             -> Compiler -> Platform                             -> InstallPlan+                            -> BuildOutcomes                             -> IO ()-updateSandboxTimestampsFile (UseSandbox sandboxDir)+updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir)                             (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))-                            comp platform installPlan =-  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do-    let allInstalled = [ pkg | InstallPlan.Installed pkg _ _-                            <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _-                            <- allInstalled ]+                            comp platform installPlan buildOutcomes =+  withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do+    let allInstalled = [ pkg+                       | InstallPlan.Configured pkg+                            <- InstallPlan.toList installPlan+                       , case InstallPlan.lookupBuildOutcome pkg buildOutcomes of+                           Just (Right _success) -> True+                           _                     -> False+                       ]+        allSrcPkgs   = [ confPkgSource cpkg | cpkg <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]     allPathsCanonical <- mapM tryCanonicalizePath allPaths     return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ = return ()+updateSandboxTimestampsFile _ _ _ _ _ _ _ = return ()  -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------  data InstallMisc = InstallMisc {-    rootCmd    :: Maybe FilePath,     libVersion :: Maybe Version   } @@ -1051,9 +1070,9 @@                      -> InstallArgs                      -> InstalledPackageIndex                      -> InstallPlan-                     -> IO InstallPlan+                     -> IO BuildOutcomes performInstallations verbosity-  (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _,+  (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do @@ -1062,26 +1081,26 @@     when parallelInstall $       notice verbosity $ "Notice: installing into a sandbox located at "                          ++ sandboxDir+  info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." -  jobControl   <- if parallelInstall then newParallelJobControl+  jobControl   <- if parallelInstall then newParallelJobControl numJobs                                      else newSerialJobControl-  buildLimit   <- newJobLimit numJobs   fetchLimit   <- newJobLimit (min numJobs numFetchJobs)   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->+  executeInstallPlan verbosity jobControl keepGoing useLogFile+                     installPlan $ \rpkg ->     installReadyPackage platform cinfo configFlags                         rpkg $ \configFlags' src pkg pkgoverride ->       fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->-        installLocalPackage verbosity buildLimit-                            (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity buildLimit installLock numJobs+        installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->+          installUnpackedPackage verbosity installLock numJobs                                  (setupScriptOptions installedPkgIndex                                   cacheLock rpkg)-                                 miscOptions configFlags'-                                 installFlags haddockFlags-                                 cinfo platform pkg rpkg pkgoverride mpath useLogFile+                                 configFlags'+                                 installFlags haddockFlags comp progdb+                                 platform pkg rpkg pkgoverride mpath useLogFile    where     cinfo = compilerInfo comp@@ -1089,6 +1108,7 @@     numJobs         = determineNumJobs (installNumJobs installFlags)     numFetchJobs    = 2     parallelInstall = numJobs >= 2+    keepGoing       = fromFlag (installKeepGoing installFlags)     distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                       (configDistPref configFlags) @@ -1097,7 +1117,7 @@         packageDBs         comp         platform-        conf+        progdb         distPref         (chooseCabalVersion configFlags (libVersion miscOptions))         (Just lock)@@ -1114,7 +1134,8 @@                  logFileTemplate       where         installLogFile' = flagToMaybe $ installLogFile installFlags-        defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"+        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@@ -1146,82 +1167,38 @@           | otherwise                         = False      substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath-    substLogFileName template pkg ipid = fromPathTemplate+    substLogFileName template pkg uid = fromPathTemplate                                   . substPathTemplate env                                   $ template-      where env = initialPathTemplateEnv (packageId pkg)-                  ipid-                  (compilerInfo comp) platform+      where env = initialPathTemplateEnv (packageId pkg) uid+                    (compilerInfo comp) platform      miscOptions  = InstallMisc {-      rootCmd    = if fromFlag (configUserInstall configFlags)-                      || (isUseSandbox useSandbox)-                     then Nothing      -- ignore --root-cmd if --user-                                       -- or working inside a sandbox.-                     else flagToMaybe (installRootCmd installFlags),       libVersion = flagToMaybe (configCabalVersion configExFlags)     }   executeInstallPlan :: Verbosity-                   -> Compiler-                   -> JobControl IO (PackageId, UnitId, BuildResult)+                   -> JobControl IO (UnitId, BuildOutcome)+                   -> Bool                    -> UseLogFile                    -> InstallPlan-                   -> (ReadyPackage -> IO BuildResult)-                   -> IO InstallPlan-executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg =-    tryNewTasks 0 plan0-  where-    tryNewTasks taskCount plan = do-      case InstallPlan.ready plan of-        [] | taskCount == 0 -> return plan-           | otherwise      -> waitForTasks taskCount plan-        pkgs                -> do-          sequence_-            [ do info verbosity $ "Ready to install " ++ display pkgid-                 spawnJob jobCtl $ do-                   buildResult <- installPkg pkg-                   let ipid = case buildResult of-                                Right (BuildOk _ _ (Just ipi)) ->-                                     Installed.installedUnitId ipi-                                _ -> mkUnitId (display (packageId pkg))-                   return (packageId pkg, ipid, buildResult)-            | pkg <- pkgs-            , let pkgid = packageId pkg ]--          let taskCount' = taskCount + length pkgs-              plan'      = InstallPlan.processing pkgs plan-          waitForTasks taskCount' plan'--    waitForTasks taskCount plan = do-      info verbosity $ "Waiting for install task to finish..."-      (pkgid, ipid, buildResult) <- collectJob jobCtl-      printBuildResult pkgid ipid buildResult-      let taskCount' = taskCount-1-          plan'      = updatePlan pkgid buildResult plan-      tryNewTasks taskCount' plan'--    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan-               -> InstallPlan-    updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =-        InstallPlan.completed (Source.fakeUnitId pkgid)-                              mipkg buildSuccess+                   -> (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 -    updatePlan pkgid (Left buildFailure) =-        InstallPlan.failed (Source.fakeUnitId pkgid)-                           buildFailure depsFailure-      where-        depsFailure = DependentFailed pkgid-        -- So this first pkgid failed for whatever reason (buildFailure).-        -- All the other packages that depended on this pkgid, which we-        -- now cannot build, we mark as failing due to 'DependentFailed'-        -- which kind of means it was not their fault.+  where+    depsFailure = DependentFailed . packageId      -- Print build log if something went wrong, and 'Installed $PKGID'     -- otherwise.-    printBuildResult :: PackageId -> UnitId -> BuildResult -> IO ()-    printBuildResult pkgid ipid buildResult = case buildResult of+    printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()+    printBuildResult pkgid uid buildOutcome = case buildOutcome of         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid@@ -1229,7 +1206,7 @@             case useLogFile of               Nothing                 -> return ()               Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid ipid+                let logName = mkLogFileName pkgid uid                 putStr $ "Build log ( " ++ logName ++ " ):\n"                 printFile logName @@ -1247,46 +1224,47 @@ installReadyPackage :: Platform -> CompilerInfo                     -> ConfigFlags                     -> ReadyPackage-                    -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                    -> (ConfigFlags -> UnresolvedPkgLoc                                     -> PackageDescription                                     -> PackageDescriptionOverride                                     -> a)                     -> a installReadyPackage platform cinfo configFlags-                    (ReadyPackage (ConfiguredPackage+                    (ReadyPackage (ConfiguredPackage ipid                                     (SourcePackage _ gpkg source pkgoverride)-                                    flags stanzas _)-                                   deps)+                                    flags stanzas deps))                     installPkg =   installPkg configFlags {+    configIPID = toFlag (display 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  = [ thisPackageVersion (packageId deppkg)-                         | deppkg <- CD.nonSetupDeps deps ],-    configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                            Installed.installedUnitId deppkg)-                         | deppkg <- CD.nonSetupDeps deps ],+    configConstraints  = [ thisPackageVersion srcid+                         | ConfiguredId srcid (Just PackageDescription.CLibName) _ipid+                            <- CD.nonSetupDeps deps ],+    configDependencies = [ (packageName srcid, dep_ipid)+                         | ConfiguredId srcid (Just PackageDescription.CLibName) 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 finalizePackageDescription flags+    pkg = case finalizePD flags (enableStanzas stanzas)            (const True)-           platform cinfo [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ReadyPackage failed"+           platform cinfo [] gpkg of+      Left _ -> error "finalizePD ReadyPackage failed"       Right (desc, _) -> desc  fetchSourcePackage   :: Verbosity   -> RepoContext   -> JobLimit-  -> PackageLocation (Maybe FilePath)-  -> (PackageLocation FilePath -> IO BuildResult)-  -> IO BuildResult+  -> UnresolvedPkgLoc+  -> (ResolvedPkgLoc -> IO BuildOutcome)+  -> IO BuildOutcome fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do   fetched <- checkFetched src   case fetched of@@ -1299,11 +1277,10 @@  installLocalPackage   :: Verbosity-  -> JobLimit-  -> PackageIdentifier -> PackageLocation FilePath -> FilePath-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installLocalPackage verbosity jobLimit pkgid location distPref installPkg =+  -> PackageIdentifier -> ResolvedPkgLoc -> FilePath+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalPackage verbosity pkgid location distPref installPkg =    case location of @@ -1311,25 +1288,24 @@       installPkg (Just dir)      LocalTarballPackage tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg      RemoteTarballPackage _ tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg      RepoTarballPackage _ _ tarballPath ->-      installLocalTarballPackage verbosity jobLimit+      installLocalTarballPackage verbosity         pkgid tarballPath distPref installPkg   installLocalTarballPackage   :: Verbosity-  -> JobLimit   -> PackageIdentifier -> FilePath -> FilePath-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installLocalTarballPackage verbosity jobLimit pkgid+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalTarballPackage verbosity pkgid                            tarballPath distPref installPkg = do   tmp <- getTemporaryDirectory   withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->@@ -1338,15 +1314,13 @@           absUnpackedPath = tmpDirPath </> relUnpackedPath           descFilePath = absUnpackedPath                      </> display (packageName pkgid) <.> "cabal"-      withJobLimit jobLimit $ do-        info verbosity $ "Extracting " ++ tarballPath-                      ++ " to " ++ tmpDirPath ++ "..."-        extractTarGzFile tmpDirPath relUnpackedPath tarballPath-        exists <- doesFileExist descFilePath-        when (not exists) $-          die $ "Package .cabal file not found: " ++ show descFilePath-        maybeRenameDistDir absUnpackedPath-+      info verbosity $ "Extracting " ++ tarballPath+                    ++ " to " ++ tmpDirPath ++ "..."+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath+      exists <- doesFileExist descFilePath+      when (not exists) $+        die' verbosity $ "Package .cabal file not found: " ++ show descFilePath+      maybeRenameDistDir absUnpackedPath       installPkg (Just absUnpackedPath)    where@@ -1379,27 +1353,25 @@  installUnpackedPackage   :: Verbosity-  -> JobLimit   -> Lock   -> Int   -> SetupScriptOptions-  -> InstallMisc   -> ConfigFlags   -> InstallFlags   -> HaddockFlags-  -> CompilerInfo+  -> 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 BuildResult-installUnpackedPackage verbosity buildLimit installLock numJobs-                       scriptOptions miscOptions-                       configFlags installFlags haddockFlags-                       cinfo platform pkg rpkg pkgoverride workingDir useLogFile = do-+  -> IO BuildOutcome+installUnpackedPackage verbosity installLock numJobs+                       scriptOptions+                       configFlags installFlags haddockFlags comp progdb+                       platform pkg rpkg pkgoverride workingDir useLogFile = do   -- Override the .cabal file if necessary   case pkgoverride of     Nothing     -> return ()@@ -1411,15 +1383,9 @@                     ++ " with the latest revision from the index."       writeFileAtomic descFilePath pkgtxt -  -- Compute the IPID-  let flags (ReadyPackage (ConfiguredPackage _ x _ _) _) = x-      cid = Configure.computeComponentId (PackageDescription.package pkg) CLibName-                (map (\(SimpleUnitId cid0) -> cid0) (CD.libraryDeps (depends rpkg))) (flags rpkg)-      ipid = SimpleUnitId cid-   -- 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 ipid configFlags+  configFlags' <- addDefaultInstallDirs configFlags   -- Filter out flags not supported by the old versions of the Cabal lib.   let configureFlags :: Version -> ConfigFlags       configureFlags  = filterConfigureFlags configFlags' {@@ -1427,11 +1393,11 @@       }    -- Path to the optional log file.-  mLogPath <- maybeLogPath ipid+  mLogPath <- maybeLogPath -  logDirChange (maybe putStr appendFile mLogPath) workingDir $ do+  logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do     -- Configure phase-    onFailure ConfigureFailed $ withJobLimit buildLimit $ do+    onFailure ConfigureFailed $ do       when (numJobs > 1) $ notice verbosity $         "Configuring " ++ display pkgid ++ "..."       setup configureCommand configureFlags mLogPath@@ -1460,23 +1426,32 @@          -- Install phase           onFailure InstallFailed $ criticalSection installLock $ do-            -- Capture installed package configuration file-            maybePkgConf <- maybeGenPkgConf mLogPath-             -- Actual installation-            withWin32SelfUpgrade verbosity ipid configFlags+            withWin32SelfUpgrade verbosity uid configFlags                                  cinfo platform pkg $ do-              case rootCmd miscOptions of-                (Just cmd) -> reexec cmd-                Nothing    -> do-                  setup Cabal.copyCommand copyFlags mLogPath-                  when shouldRegister $ do-                    setup Cabal.registerCommand registerFlags mLogPath-            return (Right (BuildOk docsResult testsResult maybePkgConf))+              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)+            forM_ ipkgs' $ \ipkg' ->+                registerPackage verbosity comp progdb+                                packageDBs ipkg'+                                defaultRegisterOptions++            return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs')))+   where     pkgid            = packageId pkg-    buildCommand'    = buildCommand defaultProgramConfiguration+    uid              = installedUnitId rpkg+    cinfo            = compilerInfo comp+    buildCommand'    = buildCommand progdb     buildFlags   _   = emptyBuildFlags {       buildDistPref  = configDistPref configFlags,       buildVerbosity = toFlag verbosity'@@ -1504,8 +1479,8 @@     verbosity' = maybe verbosity snd useLogFile     tempTemplate name = name ++ "-" ++ display pkgid -    addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags-    addDefaultInstallDirs ipid configFlags' = do+    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs configFlags' = do       defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False       return $ configFlags' {           configInstallDirs = fmap Cabal.Flag .@@ -1515,41 +1490,54 @@           }         where           CompilerId flavor _ = compilerInfoId cinfo-          env         = initialPathTemplateEnv pkgid ipid cinfo platform+          env         = initialPathTemplateEnv pkgid uid cinfo platform           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') -    maybeGenPkgConf :: Maybe FilePath-                    -> IO (Maybe Installed.InstalledPackageInfo)-    maybeGenPkgConf mLogPath =+    genPkgConfs :: Maybe FilePath+                     -> IO [Installed.InstalledPackageInfo]+    genPkgConfs mLogPath =       if shouldRegister then do         tmp <- getTemporaryDirectory-        withTempFile tmp (tempTemplate "pkgConf") $ \pkgConfFile handle -> do-          hClose handle-          let registerFlags' version = (registerFlags version) {-                Cabal.regGenPkgConf = toFlag (Just pkgConfFile)+        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-          withUTF8FileContents pkgConfFile $ \pkgConfText ->-            case Installed.parseInstalledPackageInfo pkgConfText of-              Installed.ParseFailed perror    -> pkgConfParseFailed perror-              Installed.ParseOk warns pkgConf -> do-                unless (null warns) $-                  warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)-                return (Just pkgConf)-      else return Nothing+          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 mapM (readPkgConf pkgConfDest) . sort . filter notHidden+                    =<< getDirectoryContents pkgConfDest+            else fmap (:[]) $ readPkgConf "." pkgConfDest+      else return [] +    readPkgConf :: FilePath -> FilePath+                -> IO Installed.InstalledPackageInfo+    readPkgConf pkgConfDir pkgConfFile =+      (withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfText ->+        case Installed.parseInstalledPackageInfo pkgConfText of+          Installed.ParseFailed perror    -> pkgConfParseFailed perror+          Installed.ParseOk warns pkgConf -> do+            unless (null warns) $+              warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)+            return pkgConf)+     pkgConfParseFailed :: Installed.PError -> IO a     pkgConfParseFailed perror =-      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+      die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':"             ++ show perror -    maybeLogPath :: UnitId -> IO (Maybe FilePath)-    maybeLogPath ipid =+    maybeLogPath :: IO (Maybe FilePath)+    maybeLogPath =       case useLogFile of          Nothing                 -> return Nothing          Just (mkLogFileName, _) -> do-           let logFileName = mkLogFileName (packageId pkg) ipid+           let logFileName = mkLogFileName (packageId pkg) uid                logDir      = takeDirectory logFileName            unless (null logDir) $ createDirectoryIfMissing True logDir            logFileExists <- doesFileExist logFileName@@ -1567,28 +1555,16 @@           (Just pkg)           cmd flags []) -    reexec cmd = do-      -- look for our own executable file and re-exec ourselves using a helper-      -- program like sudo to elevate privileges:-      self <- getExecutablePath-      weExist <- doesFileExist self-      if weExist-        then inDir workingDir $-               rawSystemExit verbosity cmd-                 [self, "install", "--only"-                 ,"--verbose=" ++ showForCabal verbosity]-        else die $ "Unable to find cabal executable at: " ++ self - -- helper-onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult+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 BuildResult+    handler :: Exception e => e -> IO BuildOutcome     handler = return . Left . result . toException  @@ -1604,7 +1580,7 @@                      -> PackageDescription                      -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do+withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1622,7 +1598,7 @@       [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension       | exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe)-      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix+      , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix             prefix  = substTemplate prefixTemplate             suffix  = substTemplate suffixTemplate ]       where@@ -1632,10 +1608,10 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid ipid+                           pkgid uid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid ipid+          where env = InstallDirs.initialPathTemplateEnv pkgid uid                       cinfo platform
Distribution/Client/InstallPlan.hs view
@@ -1,788 +1,943 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- 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(..),--  -- * Operations on 'InstallPlan's-  new,-  toList,-  mapPreservingGraph,--  ready,-  processing,-  completed,-  failed,-  remove,-  preexisting,-  preinstalled,--  showPlanIndex,-  showInstallPlan,--  -- * Checking validity of plans-  valid,-  closed,-  consistent,-  acyclic,--  -- ** Details on invalid plans-  PlanProblem(..),-  showPlanProblem,-  problems,--  -- ** Querying the install plan-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  ) where--import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..)-         , HasUnitId(..), UnitId(..) )-import Distribution.Client.Types-         ( BuildSuccess, BuildFailure-         , PackageFixedDeps(..), ConfiguredPackage-         , GenericReadyPackage(..), fakeUnitId )-import Distribution.Version-         ( Version )-import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Simple.PackageIndex-         ( PackageIndex )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Client.PlanIndex-         ( FakeMap )-import qualified Distribution.Client.PlanIndex as PlanIndex-import Distribution.Text-         ( display )--import Data.List-         ( foldl', intercalate )-import Data.Maybe-         ( fromMaybe, catMaybes )-import qualified Data.Graph as Graph-import Data.Graph (Graph)-import qualified Data.Tree as Tree-import Distribution.Compat.Binary (Binary(..))-import GHC.Generics-import Control.Exception-         ( assert )-import qualified Data.Map as Map-import qualified Data.Traversable as T----- 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 'PackageFixedDeps'.-data GenericPlanPackage ipkg srcpkg iresult ifailure-   = PreExisting ipkg-   | Configured  srcpkg-   | Processing  (GenericReadyPackage srcpkg ipkg)-   | Installed   (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult-   | Failed      srcpkg ifailure-  deriving (Eq, Show, Generic)--instance (Binary ipkg, Binary srcpkg, Binary  iresult, Binary  ifailure)-      => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure)--type PlanPackage = GenericPlanPackage-                   InstalledPackageInfo ConfiguredPackage-                   BuildSuccess BuildFailure--instance (Package ipkg, Package srcpkg) =>-         Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  packageId (PreExisting ipkg)     = packageId ipkg-  packageId (Configured  spkg)     = packageId spkg-  packageId (Processing  rpkg)     = packageId rpkg-  packageId (Installed   rpkg _ _) = packageId rpkg-  packageId (Failed      spkg   _) = packageId spkg--instance (PackageFixedDeps srcpkg,-          PackageFixedDeps ipkg, HasUnitId ipkg) =>-         PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  depends (PreExisting pkg)     = depends pkg-  depends (Configured  pkg)     = depends pkg-  depends (Processing  pkg)     = depends pkg-  depends (Installed   pkg _ _) = depends pkg-  depends (Failed      pkg   _) = depends pkg--instance (HasUnitId ipkg, HasUnitId srcpkg) =>-         HasUnitId-         (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  installedUnitId (PreExisting ipkg ) = installedUnitId ipkg-  installedUnitId (Configured  spkg)  = installedUnitId spkg-  installedUnitId (Processing  rpkg)  = installedUnitId rpkg-  -- NB: defer to the actual installed package info in this case-  installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg-  installedUnitId (Installed rpkg _        _) = installedUnitId rpkg-  installedUnitId (Failed      spkg        _) = installedUnitId spkg---data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {-    planIndex      :: !(PlanIndex ipkg srcpkg iresult ifailure),-    planFakeMap    :: !FakeMap,-    planIndepGoals :: !Bool,--    -- | Cached (lazily) graph-    ---    -- The 'Graph' representaion works in terms of integer node ids, so we-    -- have to keep mapping to and from our meaningful nodes, which of course-    -- are package ids.-    ---    planGraph      :: Graph,-    planGraphRev   :: Graph,  -- ^ Reverse deps, transposed-    planPkgIdOf    :: Graph.Vertex -> UnitId, -- ^ mapping back to package ids-    planVertexOf   :: UnitId -> Graph.Vertex  -- ^ mapping into node ids-  }---- | Much like 'planPkgIdOf', but mapping back to full packages.-planPkgOf :: GenericInstallPlan ipkg srcpkg iresult ifailure-          -> Graph.Vertex-          -> GenericPlanPackage ipkg srcpkg iresult ifailure-planPkgOf plan v =-    case PackageIndex.lookupUnitId (planIndex plan)-                                   (planPkgIdOf plan v) of-      Just pkg -> pkg-      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"----- | 'GenericInstallPlan' specialised to most commonly used types.-type InstallPlan = GenericInstallPlan-                   InstalledPackageInfo ConfiguredPackage-                   BuildSuccess BuildFailure--type PlanIndex ipkg srcpkg iresult ifailure =-     PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure)--invariant :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-              HasUnitId srcpkg, PackageFixedDeps srcpkg)-          => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool-invariant plan =-    valid (planFakeMap plan)-          (planIndepGoals plan)-          (planIndex plan)---- | Smart constructor that deals with caching the 'Graph' representation.----mkInstallPlan :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                  HasUnitId srcpkg, PackageFixedDeps srcpkg)-              => PlanIndex ipkg srcpkg iresult ifailure-              -> FakeMap-              -> Bool-              -> GenericInstallPlan ipkg srcpkg iresult ifailure-mkInstallPlan index fakeMap indepGoals =-    GenericInstallPlan {-      planIndex      = index,-      planFakeMap    = fakeMap,-      planIndepGoals = indepGoals,--      -- lazily cache the graph stuff:-      planGraph      = graph,-      planGraphRev   = Graph.transposeG graph,-      planPkgIdOf    = vertexToPkgId,-      planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex-    }-  where-    (graph, vertexToPkgId, pkgIdToVertex) =-      PlanIndex.dependencyGraph fakeMap index-    noSuchPkgId = internalError "package is not in the graph"--internalError :: String -> a-internalError msg = error $ "InstallPlan: internal error: " ++ msg--instance (HasUnitId ipkg,   PackageFixedDeps ipkg,-          HasUnitId srcpkg, PackageFixedDeps srcpkg,-          Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure)-       => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where-    put GenericInstallPlan {-              planIndex      = index,-              planFakeMap    = fakeMap,-              planIndepGoals = indepGoals-        } = put (index, fakeMap, indepGoals)--    get = do-      (index, fakeMap, indepGoals) <- get-      return $! mkInstallPlan index fakeMap indepGoals--showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)-              => PlanIndex ipkg srcpkg iresult ifailure -> String-showPlanIndex index =-    intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index))-  where showPlanPackage p =-            showPlanPackageTag p ++ " "-                ++ display (packageId p) ++ " ("-                ++ display (installedUnitId p) ++ ")"--showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)-                => GenericInstallPlan ipkg srcpkg iresult ifailure -> String-showInstallPlan plan =-    showPlanIndex (planIndex plan) ++ "\n" ++-    "fake map:\n  " ++-    intercalate "\n  " (map showKV (Map.toList (planFakeMap plan)))-  where showKV (k,v) = display k ++ " -> " ++ display v--showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String-showPlanPackageTag (PreExisting _)   = "PreExisting"-showPlanPackageTag (Configured  _)   = "Configured"-showPlanPackageTag (Processing  _)   = "Processing"-showPlanPackageTag (Installed _ _ _) = "Installed"-showPlanPackageTag (Failed    _   _) = "Failed"---- | Build an installation plan from a valid set of resolved packages.----new :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-        HasUnitId srcpkg, PackageFixedDeps srcpkg)-    => Bool-    -> PlanIndex ipkg srcpkg iresult ifailure-    -> Either [PlanProblem ipkg srcpkg iresult ifailure]-              (GenericInstallPlan ipkg srcpkg iresult ifailure)-new indepGoals index =-  -- NB: Need to pre-initialize the fake-map with pre-existing-  -- packages-  let isPreExisting (PreExisting _) = True-      isPreExisting _ = False-      fakeMap = Map.fromList-              . map (\p -> (fakeUnitId (packageId p)-                           ,installedUnitId p))-              . filter isPreExisting-              $ PackageIndex.allPackages index in-  case problems fakeMap indepGoals index of-    []    -> Right (mkInstallPlan index fakeMap indepGoals)-    probs -> Left probs--toList :: GenericInstallPlan ipkg srcpkg iresult ifailure-       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-toList = PackageIndex.allPackages . 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 :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-           HasUnitId srcpkg, PackageFixedDeps srcpkg)-       => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool)-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-       -> Either [PlanProblem ipkg srcpkg iresult ifailure]-                 (GenericInstallPlan ipkg srcpkg iresult ifailure)-remove shouldRemove plan =-    new (planIndepGoals plan) newIndex-  where-    newIndex = PackageIndex.fromList $-                 filter (not . shouldRemove) (toList plan)---- | The packages that are ready to be installed. That is they are in the--- configured state and have all their dependencies installed already.--- The plan is complete if the result is @[]@.----ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg-      => GenericInstallPlan ipkg srcpkg iresult ifailure-      -> [GenericReadyPackage srcpkg ipkg]-ready plan = assert check readyPackages-  where-    check = if null readyPackages && null processingPackages-              then null configuredPackages-              else True-    configuredPackages = [ pkg | Configured pkg <- toList plan ]-    processingPackages = [ pkg | Processing pkg <- toList plan]--    readyPackages :: [GenericReadyPackage srcpkg ipkg]-    readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages)--lookupReadyPackage :: forall ipkg srcpkg iresult ifailure.-                      PackageFixedDeps srcpkg-                   => GenericInstallPlan ipkg srcpkg iresult ifailure-                   -> srcpkg-                   -> Maybe (GenericReadyPackage srcpkg ipkg)-lookupReadyPackage plan pkg = do-    deps <- hasAllInstalledDeps pkg-    return (ReadyPackage pkg deps)-  where--    hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])-    hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends--    isInstalledDep :: UnitId -> Maybe ipkg-    isInstalledDep pkgid =-      -- NB: Need to check if the ID has been updated in planFakeMap, in which-      -- case we might be dealing with an old pointer-      case PlanIndex.fakeLookupUnitId-           (planFakeMap plan) (planIndex plan) pkgid-      of-        Just (PreExisting ipkg)            -> Just ipkg-        Just (Configured  _)               -> Nothing-        Just (Processing  _)               -> Nothing-        Just (Installed   _ (Just ipkg) _) -> Just ipkg-        Just (Installed   _ Nothing     _) -> internalError depOnNonLib-        Just (Failed      _             _) -> internalError depOnFailed-        Nothing                            -> internalError incomplete-    incomplete  = "install plan is not closed"-    depOnFailed = "configured package depends on failed package"-    depOnNonLib = "configured package depends on a non-library package"---- | Marks packages in the graph as currently processing (e.g. building).------ * The package must exist in the graph and be in the configured state.----processing :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-               HasUnitId srcpkg, PackageFixedDeps srcpkg)-           => [GenericReadyPackage srcpkg ipkg]-           -> GenericInstallPlan ipkg srcpkg iresult ifailure-           -> GenericInstallPlan ipkg srcpkg iresult ifailure-processing pkgs plan = assert (invariant plan') plan'-  where-    plan' = plan {-              planIndex = PackageIndex.merge (planIndex plan) processingPkgs-            }-    processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs]---- | Marks a package in the graph as completed. Also saves the build result for--- the completed package in the plan.------ * The package must exist in the graph and be in the processing state.--- * The package must have had no uninstalled dependent packages.----completed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-              HasUnitId srcpkg, PackageFixedDeps srcpkg)-          => UnitId-          -> Maybe ipkg -> iresult-          -> GenericInstallPlan ipkg srcpkg iresult ifailure-          -> GenericInstallPlan ipkg srcpkg iresult ifailure-completed pkgid mipkg buildResult plan = assert (invariant plan') plan'-  where-    plan'     = plan {-                  -- NB: installation can change the IPID, so better-                  -- record it in the fake mapping...-                  planFakeMap = insert_fake_mapping mipkg-                              $ planFakeMap plan,-                  planIndex = PackageIndex.insert installed-                            . PackageIndex.deleteUnitId pkgid-                            $ planIndex plan-                }-    -- ...but be sure to use the *old* IPID for the lookup for the-    -- preexisting record-    installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult-    insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg)-    insert_fake_mapping  _          = id---- | Marks a package in the graph as having failed. It also marks all the--- packages that depended on it as having failed.------ * The package must exist in the graph and be in the processing--- state.----failed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-           HasUnitId srcpkg, PackageFixedDeps srcpkg)-       => UnitId         -- ^ The id of the package that failed to install-       -> ifailure           -- ^ The build result to use for the failed package-       -> ifailure           -- ^ The build result to use for its dependencies-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-       -> GenericInstallPlan ipkg srcpkg iresult ifailure-failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'-  where-    -- NB: failures don't update IPIDs-    plan'    = plan {-                 planIndex = PackageIndex.merge (planIndex plan) failures-               }-    ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid-    failures = PackageIndex.fromList-             $ Failed srcpkg buildResult-             : [ Failed pkg' buildResult'-               | Just pkg' <- map checkConfiguredPackage-                            $ packagesThatDependOn plan pkgid ]---- | Lookup the reachable packages in the reverse dependency graph.----packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure-                     -> UnitId-                     -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-packagesThatDependOn plan pkgid = map (planPkgOf plan)-                          . tail-                          . Graph.reachable (planGraphRev plan)-                          . planVertexOf plan-                          $ Map.findWithDefault pkgid pkgid (planFakeMap plan)---- | Lookup a package that we expect to be in the processing state.----lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure-                        -> UnitId-                        -> GenericReadyPackage srcpkg ipkg-lookupProcessingPackage plan pkgid =-  -- NB: processing packages are guaranteed to not indirect through-  -- planFakeMap-  case PackageIndex.lookupUnitId (planIndex plan) pkgid of-    Just (Processing pkg) -> pkg-    _  -> internalError $ "not in processing state or no such pkg " ++-                          display pkgid---- | Check a package that we expect to be in the configured or failed state.----checkConfiguredPackage :: (Package srcpkg, Package ipkg)-                       => GenericPlanPackage ipkg srcpkg iresult ifailure-                       -> Maybe srcpkg-checkConfiguredPackage (Configured pkg) = Just pkg-checkConfiguredPackage (Failed     _ _) = Nothing-checkConfiguredPackage pkg                =-  internalError $ "not configured or no such pkg " ++ display (packageId pkg)---- | Replace a ready package with a pre-existing one. The pre-existing one--- must have exactly the same dependencies as the source one was configured--- with.----preexisting :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                HasUnitId srcpkg, PackageFixedDeps srcpkg)-            => UnitId-            -> ipkg-            -> GenericInstallPlan ipkg srcpkg iresult ifailure-            -> GenericInstallPlan ipkg srcpkg iresult ifailure-preexisting pkgid ipkg plan = assert (invariant plan') plan'-  where-    plan' = plan {-                    -- NB: installation can change the IPID, so better-                    -- record it in the fake mapping...-      planFakeMap = Map.insert pkgid-                               (installedUnitId ipkg)-                               (planFakeMap plan),-      planIndex   = PackageIndex.insert (PreExisting ipkg)-                    -- ...but be sure to use the *old* IPID for the lookup for-                    -- the preexisting record-                  . PackageIndex.deleteUnitId pkgid-                  $ planIndex plan-    }---- | Replace a ready package with an installed one. The installed one--- must have exactly the same dependencies as the source one was configured--- with.----preinstalled :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-                 HasUnitId srcpkg, PackageFixedDeps srcpkg)-             => UnitId-             -> Maybe ipkg -> iresult-             -> GenericInstallPlan ipkg srcpkg iresult ifailure-             -> GenericInstallPlan ipkg srcpkg iresult ifailure-preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan'-  where-    plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }-    Just installed = do-      Configured pkg <- PackageIndex.lookupUnitId (planIndex plan) pkgid-      rpkg <- lookupReadyPackage plan pkg-      return (Installed rpkg mipkg buildResult)---- | Transform an install plan by mapping a function over all the packages in--- the plan. It can consistently change the 'UnitId' of all the packages,--- while preserving the same overall graph structure.------ The mapping function has a few constraints on it for correct operation.--- The mapping function /may/ change the 'UnitId' of the package, but it--- /must/ also remap the 'UnitId's of its dependencies using ths supplied--- remapping function. Apart from this consistent remapping it /may not/--- change the structure of the dependencies.----mapPreservingGraph :: (HasUnitId ipkg,-                       HasUnitId srcpkg,-                       HasUnitId ipkg',   PackageFixedDeps ipkg',-                       HasUnitId srcpkg', PackageFixedDeps srcpkg')-                   => (  (UnitId -> UnitId)-                      -> GenericPlanPackage ipkg  srcpkg  iresult  ifailure-                      -> GenericPlanPackage ipkg' srcpkg' iresult' ifailure')-                   -> GenericInstallPlan ipkg  srcpkg  iresult  ifailure-                   -> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'-mapPreservingGraph f plan =-    mkInstallPlan (PackageIndex.fromList pkgs')-                  Map.empty -- empty fakeMap-                  (planIndepGoals plan)-  where-    -- The package mapping function may change the UnitId. So we-    -- walk over the packages in dependency order keeping track of these-    -- package id changes and use it to supply the correct set of package-    -- dependencies as an extra input to the package mapping function.-    ---    -- Having fully remapped all the deps this also means we can use an empty-    -- FakeMap for the resulting install plan.--    (_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)--    f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs)-      where-       pkg' = f (mapDep ipkgidMap) pkg--       ipkgidMap'-         | ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap-         | otherwise         =                           ipkgidMap-         where-           ipkgid  = installedUnitId pkg-           ipkgid' = installedUnitId pkg'--    mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap----- --------------------------------------------------------------- * 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 :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-          HasUnitId srcpkg, PackageFixedDeps srcpkg)-      => FakeMap -> Bool-      -> PlanIndex ipkg srcpkg iresult ifailure-      -> Bool-valid fakeMap indepGoals index =-    null $ problems fakeMap indepGoals index--data PlanProblem ipkg srcpkg iresult ifailure =-     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg iresult ifailure)-                          [PackageIdentifier]-   | PackageCycle         [GenericPlanPackage ipkg srcpkg iresult ifailure]-   | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg iresult ifailure)-                          (GenericPlanPackage ipkg srcpkg iresult ifailure)--showPlanProblem :: (Package ipkg, Package srcpkg)-                => PlanProblem ipkg srcpkg iresult ifailure -> String-showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map display missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display.packageId) cycleGroup)--showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ display name-  ++ " is required by several packages,"-  ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ display pkg ++ " requires "-                            ++ display (PackageIdentifier name ver)-             | (pkg, ver) <- inconsistencies ]--showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (packageId pkg)-  ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ display (packageId pkg')-  ++ " which is in the " ++ showPlanState pkg'-  ++ " state"-  where-    showPlanState (PreExisting _)   = "pre-existing"-    showPlanState (Configured  _)   = "configured"-    showPlanState (Processing  _)   = "processing"-    showPlanState (Installed _ _ _) = "installed"-    showPlanState (Failed    _   _) = "failed"---- | 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 :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-             HasUnitId srcpkg, PackageFixedDeps srcpkg)-         => FakeMap -> Bool-         -> PlanIndex ipkg srcpkg iresult ifailure-         -> [PlanProblem ipkg srcpkg iresult ifailure]-problems fakeMap indepGoals index =--     [ PackageMissingDeps pkg-       (catMaybes-        (map-         (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)-         missingDeps))-     | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <--       PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]--  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index)-                    (CD.flatDeps (depends pkg))-     , not (stateDependencyRelation pkg pkg') ]---- | 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 :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-            HasUnitId srcpkg, PackageFixedDeps srcpkg)-        => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap---- | 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 :: (HasUnitId ipkg, PackageFixedDeps ipkg,-           PackageFixedDeps srcpkg)-       => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-closed fakeMap = null . PlanIndex.brokenPackages fakeMap---- | 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 :: (HasUnitId ipkg,   PackageFixedDeps ipkg,-               HasUnitId srcpkg, PackageFixedDeps srcpkg)-           => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool-consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap 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 :: GenericPlanPackage ipkg srcpkg iresult ifailure-                        -> GenericPlanPackage ipkg srcpkg iresult ifailure-                        -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _)   = True--stateDependencyRelation (Configured  _) (PreExisting _)   = True-stateDependencyRelation (Configured  _) (Configured  _)   = True-stateDependencyRelation (Configured  _) (Processing  _)   = True-stateDependencyRelation (Configured  _) (Installed _ _ _) = True--stateDependencyRelation (Processing  _) (PreExisting _)   = True-stateDependencyRelation (Processing  _) (Installed _ _ _) = True--stateDependencyRelation (Installed _ _ _) (PreExisting _)   = True-stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True--stateDependencyRelation (Failed    _ _) (PreExisting _)   = True--- failed can depends on configured because a package can depend on--- several other packages and if one of the deps fail then we fail--- but we still depend on the other ones that did not fail:-stateDependencyRelation (Failed    _ _) (Configured  _)   = True-stateDependencyRelation (Failed    _ _) (Processing  _)   = True-stateDependencyRelation (Failed    _ _) (Installed _ _ _) = True-stateDependencyRelation (Failed    _ _) (Failed    _   _) = True--stateDependencyRelation _               _                 = False----- | Compute the dependency closure of a package in a install plan----dependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure-                  -> [UnitId]-                  -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-dependencyClosure plan =-    map (planPkgOf plan)-  . concatMap Tree.flatten-  . Graph.dfs (planGraph plan)-  . map (planVertexOf plan)---reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure-                         -> [UnitId]-                         -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-reverseDependencyClosure plan =-    map (planPkgOf plan)-  . concatMap Tree.flatten-  . Graph.dfs (planGraphRev plan)-  . map (planVertexOf plan)---topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure-                 -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-topologicalOrder plan =-    map (planPkgOf plan)-  . Graph.topSort-  $ planGraph plan---reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure-                        -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-reverseTopologicalOrder plan =-    map (planPkgOf plan)-  . Graph.topSort-  $ planGraphRev plan+{-# 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+  reverseTopologicalOrder,+  reverseDependencyClosure,+  ) where++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.Text+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++-- TODO: Need this when we compute final UnitIds+-- import qualified Distribution.Simple.Configure as Configure++import Data.List+         ( foldl', intercalate )+import qualified Data.Foldable as Foldable (all)+import Data.Maybe+         ( fromMaybe, catMaybes )+import qualified Distribution.Compat.Graph as Graph+import Distribution.Compat.Graph (Graph, IsNode(..))+import Distribution.Compat.Binary (Binary(..))+import GHC.Generics+import Data.Typeable+import Control.Monad+import Control.Exception+         ( assert )+import qualified Data.Map as Map+import           Data.Map (Map)+import qualified Data.Set as Set+import           Data.Set (Set)++import Prelude hiding (lookup)+++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- 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)++-- | 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)++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 :: String -> String -> a+internalError loc msg = error $ "internal error in InstallPlan." ++ loc+                             ++ if null msg then "" else ": " ++ msg++instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,+          Binary ipkg, Binary srcpkg)+       => Binary (GenericInstallPlan ipkg srcpkg) where+    put GenericInstallPlan {+              planGraph      = graph,+              planIndepGoals = indepGoals+        } = put (graph, indepGoals)++    get = do+      (graph, indepGoals) <- get+      return $! mkInstallPlan "(instance Binary)" graph indepGoals++showPlanGraph :: (Package ipkg, Package srcpkg,+                  IsUnit ipkg, IsUnit srcpkg)+              => Graph (GenericPlanPackage ipkg srcpkg) -> String+showPlanGraph graph = renderStyle defaultStyle $+    vcat (map dispPlanPackage (Graph.toList graph))+  where dispPlanPackage p =+            hang (hsep [ text (showPlanPackageTag p)+                       , disp (packageId p)+                       , parens (disp (nodeKey p))]) 2+                 (vcat (map disp (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 = Graph.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 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 " ++ display uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display 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 " ++ display uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display 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+                        (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 :: (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 (Configured pkg) = ReadyPackage pkg+    asReadyPackage _ = internalError "completed" ""++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 _ = internalError "failed" "not in configured state"++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 " ++ display (nodeKey pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display . nodeKey) cycleGroup)+showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (nodeKey pkg)+  ++ " is in the " ++ showPlanPackageTag pkg+  ++ " state but it depends on package " ++ display (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+       (catMaybes+        (map+         (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 <- Graph.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 view
@@ -16,10 +16,12 @@     symlinkBinary,   ) where -#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS  import Distribution.Package (PackageIdentifier)+import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler@@ -28,33 +30,36 @@ symlinkBinaries :: Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags-                -> InstallPlan -                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries _ _ _ _ _ = return []+                -> InstallPlan+                -> BuildOutcomes+                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]+symlinkBinaries _ _ _ _ _ _ = return [] -symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool+symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"  #else  import Distribution.Client.Types-         ( SourcePackage(..)-         , GenericReadyPackage(..), ReadyPackage, enableStanzas-         , ConfiguredPackage(..) , fakeUnitId)+         ( 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(..) )+         ( 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-         ( finalizePackageDescription )+         ( finalizePD ) import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs@@ -62,6 +67,8 @@          ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System          ( Platform )+import Distribution.Text+         ( display )  import System.Posix.Files          ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink@@ -104,8 +111,9 @@                 -> ConfigFlags                 -> InstallFlags                 -> InstallPlan-                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries platform comp configFlags installFlags plan =+                -> BuildOutcomes+                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]+symlinkBinaries platform comp configFlags installFlags plan buildOutcomes =   case flagToMaybe (installSymlinkBinDir installFlags) of     Nothing            -> return []     Just symlinkBinDir@@ -123,31 +131,32 @@                then return Nothing                else return (Just (pkgid, publicExeName,                                   privateBinDir </> privateExeName))-        | (ReadyPackage (ConfiguredPackage _ _flags _ _) _, pkg, exe) <- exes+        | (rpkg, pkg, exe) <- exes         , let pkgid  = packageId pkg               -- This is a bit dodgy; probably won't work for Backpack packages-              ipid = fakeUnitId pkgid+              ipid = installedUnitId rpkg               publicExeName  = PackageDescription.exeName exe-              privateExeName = prefix ++ publicExeName ++ suffix+              privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix               prefix = substTemplate pkgid ipid prefixTemplate               suffix = substTemplate pkgid ipid suffixTemplate ]   where     exes =       [ (cpkg, pkg, exe)-      | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan-      , let pkg   = pkgDescription cpkg+      | 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 :: ReadyPackage -> PackageDescription-    pkgDescription (ReadyPackage (ConfiguredPackage-                                    (SourcePackage _ pkg _ _)-                                    flags stanzas _)-                                  _) =-      case finalizePackageDescription flags+    pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _)+                                      flags stanzas _) =+      case finalizePD flags (enableStanzas stanzas)              (const True)-             platform cinfo [] (enableStanzas stanzas pkg) of-        Left _ -> error "finalizePackageDescription ReadyPackage failed"+             platform cinfo [] pkg of+        Left _ -> error "finalizePD ReadyPackage failed"         Right (desc, _) -> desc      -- This is sadly rather complicated. We're kind of re-doing part of the@@ -177,30 +186,32 @@     cinfo            = compilerInfo comp     (CompilerId compilerFlavor _) = compilerInfoId cinfo -symlinkBinary :: 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@-              -> String   -- ^ 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 ::+  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@+  -> UnqualComponentName -- ^ 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 publicBindir privateBindir publicName privateName = do-  ok <- targetOkToOverwrite (publicBindir </> publicName)+  ok <- targetOkToOverwrite (publicBindir </> publicName')                             (privateBindir </> privateName)   case ok of     NotOurFile    ->                     return False     NotExists     ->           mkLink >> return True     OkToOverwrite -> rmLink >> mkLink >> return True   where+    publicName' = display publicName     relativeBindir = makeRelative publicBindir privateBindir     mkLink = createSymbolicLink (relativeBindir </> privateName)-                                (publicBindir   </> publicName)-    rmLink = removeLink (publicBindir </> publicName)+                                (publicBindir   </> publicName')+    rmLink = removeLink (publicBindir </> publicName')  -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or
Distribution/Client/JobControl.hs view
@@ -16,6 +16,8 @@     newParallelJobControl,     spawnJob,     collectJob,+    remainingJobs,+    cancelJobs,      JobLimit,     newJobLimit,@@ -27,48 +29,131 @@   ) where  import Control.Monad-import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem)-import Control.Exception (SomeException, bracket_, mask, throw, try)+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 (SomeException, bracket_, throwIO, try) 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 (),-       collectJob  :: m a++       -- | 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-    queue <- newChan+    qVar <- newTChanIO     return JobControl {-      spawnJob   = spawn queue,-      collectJob = collect queue+      spawnJob      = spawn     qVar,+      collectJob    = collect   qVar,+      remainingJobs = remaining qVar,+      cancelJobs    = cancel    qVar     }   where-    spawn :: Chan (IO a) -> IO a -> IO ()-    spawn = writeChan+    spawn :: TChan (IO a) -> IO a -> IO ()+    spawn qVar job = atomically $ writeTChan qVar job -    collect :: Chan (IO a) -> IO a-    collect = join . readChan+    collect :: TChan (IO a) -> IO a+    collect qVar =+      join $ atomically $ readTChan qVar -newParallelJobControl :: IO (JobControl IO a)-newParallelJobControl = do-    resultVar <- newEmptyMVar+    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 :: 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 resultVar,-      collectJob = collect resultVar+      spawnJob      = spawn   inqVar  countVar,+      collectJob    = collect outqVar countVar,+      remainingJobs = remaining       countVar,+      cancelJobs    = cancel  inqVar  countVar     }   where-    spawn :: MVar (Either SomeException a) -> IO a -> IO ()-    spawn resultVar job =-      mask $ \restore ->-        forkIO (do res <- try (restore job)-                   putMVar resultVar res)-         >> return ()+    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 -    collect :: MVar (Either SomeException a) -> IO a-    collect resultVar =-      takeMVar resultVar >>= either throw return+    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
Distribution/Client/List.hs view
@@ -14,38 +14,41 @@   ) where  import Distribution.Package-         ( PackageName(..), Package(..), packageName, packageVersion-         , Dependency(..), simplifyDependency-         , UnitId )+         ( 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-         ( Flag(..), FlagName(..) )+         ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )  import Distribution.Simple.Compiler         ( Compiler, PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils-        ( equating, comparing, die, notice )+        ( equating, comparing, die', notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version-         ( Version(..), VersionRange, withinRange, anyVersion+         ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion          , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) import Distribution.Text          ( Text(disp), display ) +import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage+ import Distribution.Client.Types-         ( SourcePackage(..), SourcePackageDb(..) )-import Distribution.Client.Dependency.Types-         ( PackageConstraint(..) )+         ( SourcePackageDb(..)+         , UnresolvedSourcePackage ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup@@ -61,7 +64,7 @@ import Data.List          ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) import Data.Maybe-         ( listToMaybe, fromJust, fromMaybe, isJust )+         ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList ) import qualified Data.Map as Map import Data.Tree as Tree import Control.Monad@@ -78,19 +81,19 @@            -> PackageDBStack            -> RepoContext            -> Compiler-           -> ProgramConfiguration+           -> ProgramDb            -> ListFlags            -> [String]            -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do-    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb))          pkgsInfo ::-          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]         pkgsInfo             -- gather info for all packages           | null pats = mergePackages@@ -101,7 +104,7 @@           | otherwise = pkgsInfoMatching          pkgsInfoMatching ::-          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]         pkgsInfoMatching =           let matchingInstalled = matchingPackages                                   InstalledPackageIndex.searchByNameSubstring@@ -134,12 +137,12 @@      -> PackageDBStack      -> RepoContext      -> Compiler-     -> ProgramConfiguration+     -> ProgramDb      -> ListFlags      -> [String]      -> IO ()-list verbosity packageDBs repos comp conf listFlags pats = do-    matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats+list verbosity packageDBs repos comp progdb listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats      if simpleOutput       then putStr $ unlines@@ -164,7 +167,7 @@      -> PackageDBStack      -> RepoContext      -> Compiler-     -> ProgramConfiguration+     -> ProgramDb      -> GlobalFlags      -> InfoFlags      -> [UserTarget]@@ -172,10 +175,10 @@ info verbosity _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -info verbosity packageDBs repoCtxt comp conf+info verbosity packageDBs repoCtxt comp progdb      globalFlags _listFlags userTargets = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb     sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion@@ -194,7 +197,7 @@                        sourcePkgs' userTargets      pkgsinfo      <- sequence-                       [ do pkginfo <- either die return $+                       [ do pkginfo <- either (die' verbosity) return $                                          gatherPkgInfo prefs                                            installedPkgIndex sourcePkgIndex                                            pkgSpecifier@@ -206,11 +209,11 @@   where     gatherPkgInfo :: (PackageName -> VersionRange) ->                      InstalledPackageIndex ->-                     PackageIndex.PackageIndex SourcePackage ->-                     PackageSpecifier SourcePackage ->+                     PackageIndex.PackageIndex UnresolvedSourcePackage ->+                     PackageSpecifier UnresolvedSourcePackage ->                      Either String PackageDisplayInfo     gatherPkgInfo prefs installedPkgIndex sourcePkgIndex-      (NamedPackage name constraints)+      (NamedPackage name props)       | null (selectedInstalledPkgs) && null (selectedSourcePkgs)       = Left $ "There is no available version of " ++ display name             ++ " that satisfies "@@ -235,7 +238,7 @@                          -- supplied a non-trivial version constraint         showPkgVersion = not (null verConstraints)         verConstraint  = foldr intersectVersionRanges anyVersion verConstraints-        verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ]+        verConstraints = [ vr | PackagePropertyVersion vr <- props ]      gatherPkgInfo prefs installedPkgIndex sourcePkgIndex       (SpecificSourcePackage pkg) =@@ -251,8 +254,8 @@   (PackageName -> VersionRange)   -> PackageName   -> InstalledPackageIndex-  -> PackageIndex.PackageIndex SourcePackage-  -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage])+  -> PackageIndex.PackageIndex UnresolvedSourcePackage+  -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =   (pref, installedPkgs, sourcePkgs)   where@@ -268,7 +271,7 @@ data PackageDisplayInfo = PackageDisplayInfo {     pkgName           :: PackageName,     selectedVersion   :: Maybe Version,-    selectedSourcePkg :: Maybe SourcePackage,+    selectedSourcePkg :: Maybe UnresolvedSourcePackage,     installedVersions :: [Version],     sourceVersions    :: [Version],     preferredVersions :: VersionRange,@@ -285,7 +288,7 @@     flags             :: [Flag],     hasLib            :: Bool,     hasExe            :: Bool,-    executables       :: [String],+    executables       :: [UnqualComponentName],     modules           :: [ModuleName],     haddockHtml       :: FilePath,     haveTarball       :: Bool@@ -346,7 +349,7 @@    , entry "Author"        author       hideIfNull     reflowLines    , entry "Maintainer"    maintainer   hideIfNull     reflowLines    , entry "Source repo"   sourceRepo   orNotSpecified text-   , entry "Executables"   executables  hideIfNull     (commaSep text)+   , entry "Executables"   executables  hideIfNull     (commaSep disp)    , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)    , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)    , entry "Documentation" haddockHtml  showIfInstalled text@@ -378,7 +381,7 @@     orNotSpecified = altText null "[ Not specified ]"      commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f-    dispFlag f = case flagName f of FlagName n -> text n+    dispFlag = text . unFlagName . flagName     dispYesNo True  = text "Yes"     dispYesNo False = text "No" @@ -417,8 +420,8 @@ -- mergePackageInfo :: VersionRange                  -> [Installed.InstalledPackageInfo]-                 -> [SourcePackage]-                 -> Maybe SourcePackage+                 -> [UnresolvedSourcePackage]+                 -> Maybe UnresolvedSourcePackage                  -> Bool                  -> PackageDisplayInfo mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =@@ -462,7 +465,8 @@     executables  = map fst (maybe [] Source.condExecutables sourceGeneric),     modules      = combine (map Installed.exposedName . Installed.exposedModules)                            installed-                           (maybe [] getListOfExposedModules . Source.library)+                           -- NB: only for the PUBLIC library+                           (concatMap getListOfExposedModules . maybeToList . Source.library)                            source,     dependencies =       combine (map (SourceDependency . simplifyDependency)@@ -520,10 +524,10 @@ -- both be empty. -- mergePackages :: [Installed.InstalledPackageInfo]-              -> [SourcePackage]+              -> [UnresolvedSourcePackage]               -> [( PackageName                   , [Installed.InstalledPackageInfo]-                  , [SourcePackage] )]+                  , [UnresolvedSourcePackage] )] mergePackages installedPkgs sourcePkgs =     map collect   $ mergeBy (\i a -> fst i `compare` fst a)@@ -567,13 +571,13 @@ -- interestingVersions :: (Version -> Bool) -> [Version] -> [Version] interestingVersions pref =-      map ((\ns -> Version ns []) . fst) . filter snd+      map (mkVersion . fst) . filter snd     . concat  . Tree.levels     . swizzleTree-    . reorderTree (\(Node (v,_) _) -> pref (Version v []))+    . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))     . reverseTree     . mkTree-    . map versionBranch+    . map versionNumbers    where     swizzleTree = unfoldTree (spine [])
Distribution/Client/Manpage.hs view
@@ -56,7 +56,7 @@   , "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 "+  , "which is Haskell's central package archive that contains thousands of libraries and applications "   , "in the Cabal package format."   , ".SH OPTIONS"   , "Global options:"
+ Distribution/Client/Nix.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++module Distribution.Client.Nix+       ( findNixExpr+       , inNixShell+       , nixInstantiate+       , nixShell+       , nixShellIfSandboxed+       ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Exception (bracket, catch)+import Control.Monad (filterM, when, unless)+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.Compat.Semigroup++import Distribution.Verbosity++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(..))+import Distribution.Client.Sandbox.Types (UseSandbox(..))+++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 = maybe False (const True) <$> 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+++nixShellIfSandboxed+  :: Verbosity+  -> FilePath+  -> GlobalFlags+  -> SavedConfig+  -> UseSandbox+  -> IO ()+     -- ^ The action to perform inside a nix-shell. This is also the action+     -- that will be performed immediately if Nix is disabled.+  -> IO ()+nixShellIfSandboxed verb dist globalFlags config useSandbox go =+  case useSandbox of+    NoSandbox -> go+    UseSandbox _ -> nixShell verb dist globalFlags config go
+ Distribution/Client/Outdated.hs view
@@ -0,0 +1,204 @@+{-# 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.Package                          (PackageName, packageVersion)+import Distribution.PackageDescription               (buildDepends)+import Distribution.PackageDescription.Configuration (finalizePD)+import Distribution.Simple.Compiler                  (Compiler, compilerInfo)+import Distribution.Simple.Setup                     (fromFlagOrDefault)+import Distribution.Simple.Utils+       (die', notice, debug, tryFindPackageDesc)+import Distribution.System                           (Platform)+import Distribution.Text                             (display)+import Distribution.Types.ComponentRequestedSpec     (ComponentRequestedSpec(..))+import Distribution.Types.Dependency+       (Dependency(..), depPkgName, simplifyDependency)+import Distribution.Verbosity                        (Verbosity, silent)+import Distribution.Version+       (Version, LowerBound(..), UpperBound(..)+       ,asVersionIntervals, majorBoundVersion)+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+       (readGenericPackageDescription)+#else+import Distribution.PackageDescription.Parse+       (readGenericPackageDescription)+#endif++import qualified Data.Set as S+import System.Directory                              (getCurrentDirectory)+import System.Exit                                   (exitFailure)+import Control.Exception                             (throwIO)++-- | 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)+      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++  sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext+  let pkgIndex = packageIndex sourcePkgDb+  deps <- if freezeFile+          then depsFromFreezeFile verbosity+          else if newFreezeFile+               then depsFromNewFreezeFile verbosity+               else depsFromPkgDesc       verbosity comp platform+  debug verbosity $ "Dependencies loaded: "+    ++ (intercalate ", " $ map display 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 -> [(Dependency,Version)] -> Bool -> IO ()+showResult verbosity outdatedDeps simpleOutput =+  if (not . null $ outdatedDeps)+    then+    do when (not simpleOutput) $+         notice verbosity "Outdated dependencies:"+       for_ outdatedDeps $ \(d@(Dependency pn _), v) ->+         let outdatedDep = if simpleOutput then display pn+                           else display d ++ " (latest: " ++ display 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] -> [Dependency]+userConstraintsToDependencies ucnstrs =+  mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs++-- | Read the list of dependencies from the freeze file.+depsFromFreezeFile :: Verbosity -> IO [Dependency]+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 -> IO [Dependency]+depsFromNewFreezeFile verbosity = do+  projectRoot <- either throwIO return =<<+                 findProjectRoot Nothing {- TODO: Support '--project-file': -} Nothing+  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"+  return deps++-- | Read the list of dependencies from the package description.+depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [Dependency]+depsFromPkgDesc verbosity comp platform = do+  cwd  <- getCurrentDirectory+  path <- tryFindPackageDesc cwd+  gpd  <- readGenericPackageDescription verbosity path+  let cinfo = compilerInfo comp+      epd = finalizePD [] (ComponentRequestedSpec True True)+            (const True) platform cinfo [] gpd+  case epd of+    Left _        -> die' verbosity "finalizePD failed"+    Right (pd, _) -> do+      let bd = buildDepends pd+      debug verbosity+        "Reading the list of dependencies from the package description"+      return bd++-- | 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 :: [Dependency]+             -> PackageIndex UnresolvedSourcePackage+             -> ListOutdatedSettings+             -> [(Dependency, Version)]+listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =+  mapMaybe isOutdated $ map simplifyDependency deps+  where+    isOutdated :: Dependency -> Maybe (Dependency, Version)+    isOutdated dep+      | ignorePred (depPkgName dep) = Nothing+      | otherwise                   =+          let this   = map packageVersion $ lookupDependency pkgIndex dep+              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 :: Dependency -> [Version]+    lookupLatest dep+      | minorPred (depPkgName dep) =+        map packageVersion $ lookupDependency pkgIndex  (relaxMinor dep)+      | otherwise                  =+        map packageVersion $ lookupPackageName pkgIndex (depPkgName dep)++    relaxMinor :: Dependency -> Dependency+    relaxMinor (Dependency pn vr) = (Dependency pn vr')+      where+        vr' = let vis = asVersionIntervals vr+                  (LowerBound v0 _,upper) = last vis+              in case upper of+                   NoUpperBound     -> vr+                   UpperBound _v1 _ -> majorBoundVersion v0
Distribution/Client/PackageHash.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}  -- | Functions to calculate nix-style hashes for package ids. --@@ -29,11 +30,12 @@   ) where  import Distribution.Package-         ( PackageId, PackageIdentifier(..), mkUnitId )+         ( PackageId, PackageIdentifier(..), mkComponentId+         , PkgconfigName ) import Distribution.System          ( Platform, OS(Windows), buildOS ) import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )+         ( FlagAssignment, showFlagValue ) import Distribution.Simple.Compiler          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)          , ProfDetailLevel(..), showProfDetailLevel )@@ -41,8 +43,10 @@          ( PathTemplate, fromPathTemplate ) import Distribution.Text          ( display )+import Distribution.Version import Distribution.Client.Types          ( InstalledPackageId )+import qualified Distribution.Solver.Types.ComponentDeps as CD  import qualified Hackage.Security.Client    as Sec @@ -50,11 +54,14 @@ import qualified Data.ByteString.Base16     as Base16 import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Map as Map import qualified Data.Set as Set import           Data.Set (Set) +import Data.Typeable import Data.Maybe        (catMaybes) import Data.List         (sortBy, intercalate)+import Data.Map          (Map) import Data.Function     (on) import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate)@@ -85,7 +92,7 @@ -- hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} =-    mkUnitId $+    mkComponentId $          display pkgHashPkgId   -- to be a bit user friendly       ++ "-"       ++ showHashValue (hashPackageHashInputs pkghashinputs)@@ -105,12 +112,12 @@ -- 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 securty+-- rely on the hash primarily for collision avoidance not for any security -- properties (at least for now). -- hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =-    mkUnitId $+    mkComponentId $       intercalate "-"         -- max length now 64         [ truncateStr 14 (display name)@@ -133,7 +140,9 @@ -- data PackageHashInputs = PackageHashInputs {        pkgHashPkgId         :: PackageId,+       pkgHashComponent     :: Maybe CD.Component,        pkgHashSourceHash    :: PackageSourceHash,+       pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe Version),        pkgHashDirectDeps    :: Set InstalledPackageId,        pkgHashOtherConfig   :: PackageHashConfigInputs      }@@ -162,13 +171,13 @@        pkgHashStripLibs           :: Bool,        pkgHashStripExes           :: Bool,        pkgHashDebugInfo           :: DebugInfoLevel,+       pkgHashProgramArgs         :: Map String [String],        pkgHashExtraLibDirs        :: [FilePath],        pkgHashExtraFrameworkDirs  :: [FilePath],        pkgHashExtraIncludeDirs    :: [FilePath],        pkgHashProgPrefix          :: Maybe PathTemplate,        pkgHashProgSuffix          :: Maybe PathTemplate ---     TODO: [required eventually] extra program options --     TODO: [required eventually] pkgHashToolsVersions     ? --     TODO: [required eventually] pkgHashToolsExtraOptions ? --     TODO: [research required] and what about docs?@@ -188,8 +197,10 @@ renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString renderPackageHashInputs PackageHashInputs{                           pkgHashPkgId,+                          pkgHashComponent,                           pkgHashSourceHash,                           pkgHashDirectDeps,+                          pkgHashPkgConfigDeps,                           pkgHashOtherConfig =                             PackageHashConfigInputs{..}                         } =@@ -207,9 +218,16 @@     --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+    LBS.pack $ unlines $ catMaybes $       [ entry "pkgid"       display pkgHashPkgId+      , mentry "component"  show pkgHashComponent       , entry "src"         showHashValue pkgHashSourceHash+      , entry "pkg-config-deps"+                            (intercalate ", " . map (\(pn, mb_v) -> display pn +++                                                    case mb_v of+                                                        Nothing -> ""+                                                        Just v -> " " ++ display v)+                                              . Set.toList) pkgHashPkgConfigDeps       , entry "deps"        (intercalate ", " . map display                                               . Set.toList) pkgHashDirectDeps         -- and then all the config@@ -236,17 +254,15 @@       , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs       , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix       , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix-      ]+      ] ++ 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 -    showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)-      where-        showEntry (FlagName name, False) = '-' : name-        showEntry (FlagName name, True)  = '+' : name+    showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst)  ----------------------------------------------- -- The specific choice of hash implementation@@ -263,7 +279,7 @@ -- package ids.  newtype HashValue = HashValue BS.ByteString-  deriving (Eq, Show)+  deriving (Eq, Show, Typeable)  instance Binary HashValue where   put (HashValue digest) = put digest
− Distribution/Client/PackageIndex.hs 
@@ -1,318 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.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.Client.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,-  insert,-  deletePackageName,-  deletePackageId,-  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  elemByPackageId,-  elemByPackageName,-  lookupPackageName,-  lookupPackageId,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  ) where--import Prelude hiding (lookup)-import Control.Exception (assert)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.List (groupBy, sortBy, isInfixOf)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-import Data.Maybe (isJust, fromMaybe)-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup (Semigroup((<>)))--import Distribution.Package-         ( PackageName(..), PackageIdentifier(..)-         , Package(..), packageName, packageVersion-         , Dependency(Dependency) )-import Distribution.Version-         ( withinRange )-import Distribution.Simple.Utils-         ( lowercase, comparing )----- | 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 = 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 head-                -- Eq instance for PackageIdentifier is wrong, so use Ord:-              . 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---- | 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 => Dependency -> PackageIndex pkg -> PackageIndex pkg-deleteDependency (Dependency 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 -> Dependency -> [pkg]-lookupDependency index (Dependency 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@(PackageName name',_) <- Map.toList m-    , lowercase name' == 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 (PackageIndex m) searchterm =-    [ pkgs-    | pkgs@(PackageName name, _) <- Map.toList m-    , lsearchterm `isInfixOf` lowercase name ]-  where-    lsearchterm = lowercase searchterm
Distribution/Client/PackageUtils.hs view
@@ -15,11 +15,13 @@   ) where  import Distribution.Package-         ( packageVersion, packageName, Dependency(..) )+         ( packageVersion, packageName )+import Distribution.Types.Dependency+import Distribution.Types.UnqualComponentName import Distribution.PackageDescription-         ( PackageDescription(..) )+         ( PackageDescription(..), libName ) import Distribution.Version-         ( withinRange )+         ( withinRange, isAnyVersion )  -- | The list of dependencies that refer to external packages -- rather than internal package components.@@ -30,5 +32,7 @@     -- True if this dependency is an internal one (depends on a library     -- defined in the same package).     internal (Dependency depName versionRange) =-            depName == packageName pkg &&-            packageVersion pkg `withinRange` versionRange+           (depName == packageName pkg &&+            packageVersion pkg `withinRange` versionRange) ||+           (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) &&+            isAnyVersion versionRange)
− Distribution/Client/PkgConfigDb.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.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.Client.PkgConfigDb-    ( PkgConfigDb-    , readPkgConfigDb-    , pkgConfigDbFromList-    , pkgConfigPkgIsPresent-    , getPkgConfigDbDirs-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif--import Control.Exception (IOException, handle)-import Data.Char (isSpace)-import qualified Data.Map as M-import Data.Version (parseVersion)-import Text.ParserCombinators.ReadP (readP_to_S)-import System.FilePath (splitSearchPath)--import Distribution.Package-    ( PackageName(..) )-import Distribution.Verbosity-    ( Verbosity )-import Distribution.Version-    ( Version, VersionRange, withinRange )--import Distribution.Compat.Environment-    ( lookupEnv )-import Distribution.Simple.Program-    ( ProgramConfiguration, pkgConfigProgram, getProgramOutput,-      requireProgram )-import Distribution.Simple.Utils-    ( info )---- | 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 PackageName (Maybe Version))-                 -- ^ 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)---- | Query pkg-config for the list of installed packages, together--- with their versions. Return a `PkgConfigDb` encapsulating this--- information.-readPkgConfigDb :: Verbosity -> ProgramConfiguration -> IO PkgConfigDb-readPkgConfigDb verbosity conf = handle ioErrorHandler $ do-  (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf-  pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]-  -- The output of @pkg-config --list-all@ also includes a description-  -- for each package, which we do not need.-  let pkgNames = map (takeWhile (not . isSpace)) pkgList-  pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig-                             ("--modversion" : pkgNames)-  (return . pkgConfigDbFromList . zip pkgNames) pkgVersions-      where-        -- For when pkg-config invocation fails (possibly because of a-        -- too long command line).-        ioErrorHandler :: IOException -> IO PkgConfigDb-        ioErrorHandler e = do-          info verbosity ("Failed to query pkg-config, Cabal will continue"-                          ++ " without solving for pkg-config constraints: "-                          ++ show e)-          return NoPkgConfigDb---- | 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) -> (PackageName, Maybe Version)-      convert (n,vs) = (PackageName n,-                        case (reverse . readP_to_S parseVersion) vs of-                          (v, "") : _ -> Just v-                          _           -> Nothing -- Version not (fully)-                                                 -- understood.-                       )---- | Check whether a given package range is satisfiable in the given--- @pkg-config@ database.-pkgConfigPkgIsPresent :: PkgConfigDb -> PackageName -> VersionRange -> 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) -> withinRange 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 pkg-config for the locations of pkg-config's package files. Use this--- to monitor for changes in the pkg-config DB.----getPkgConfigDbDirs :: Verbosity -> ProgramConfiguration -> IO [FilePath]-getPkgConfigDbDirs verbosity conf =-    (++) <$> 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-      (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf-      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/Client/PlanIndex.hs 
@@ -1,289 +0,0 @@--- | These graph traversal functions mirror the ones in Cabal, but work with--- the more complete (and fine-grained) set of dependencies provided by--- PackageFixedDeps rather than only the library dependencies provided by--- PackageInstalled.-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-module Distribution.Client.PlanIndex (-    -- * FakeMap and related operations-    FakeMap-  , fakeDepends-  , fakeLookupUnitId-    -- * Graph traversal functions-  , brokenPackages-  , dependencyCycles-  , dependencyGraph-  , dependencyInconsistencies-  ) where--import Prelude hiding (lookup)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import Data.Array ((!))-import Data.Map (Map)-import Data.Maybe (isNothing)-import Data.Either (rights)--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif--import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), UnitId(..)-         , Package(..), packageName, packageVersion-         )-import Distribution.Version-         ( Version )--import Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.ComponentDeps as CD-import Distribution.Client.Types-         ( PackageFixedDeps(..) )-import Distribution.Simple.PackageIndex-         ( PackageIndex, allPackages, insert, lookupUnitId )-import Distribution.Package-         ( HasUnitId(..), PackageId )---- Note [FakeMap]--------------------- We'd like to use the PackageIndex defined in this module for cabal-install's--- InstallPlan.  However, at the moment, this data structure is indexed by--- UnitId, which we don't know until after we've compiled a package--- (whereas InstallPlan needs to store not-compiled packages in the index.)--- Eventually, an UnitId will be calculatable prior to actually building--- the package, but at the moment, the "fake installed package ID map" is a--- workaround to solve this problem while reusing PackageIndex.  The basic idea--- is that, since we don't know what an UnitId is beforehand, we just fake--- up one based on the package ID (it only needs to be unique for the particular--- install plan), and fill it out with the actual generated UnitId after--- the package is successfully compiled.------ However, there is a problem: in the index there may be references using the--- old package ID, which are now dangling if we update the UnitId.  We--- could map over the entire index to update these pointers as well (a costly--- operation), but instead, we've chosen to parametrize a variety of important--- functions by a FakeMap, which records what a fake installed package ID was--- actually resolved to post-compilation.  If we do a lookup, we first check and--- see if it's a fake ID in the FakeMap.------ It's a bit grungy, but we expect this to only be temporary anyway.  (Another--- possible workaround would have been to *not* update the installed package ID,--- but I decided this would be hard to understand.)---- | Map from fake package keys to real ones.  See Note [FakeMap]-type FakeMap = Map UnitId UnitId---- | Variant of `depends` which accepts a `FakeMap`------ Analogous to `fakeInstalledDepends`. See Note [FakeMap].-fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId]-fakeDepends fakeMap = fmap (map resolveFakeId) . depends-  where-    resolveFakeId :: UnitId -> UnitId-    resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap----- | Variant of 'lookupUnitId' which accepts a 'FakeMap'.  See Note---- [FakeMap].-fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId-                             -> Maybe a-fakeLookupUnitId fakeMap index pkg =-  lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)---- | All packages that have dependencies that are not in the index.------ Returns such packages along with the dependencies that they're missing.----brokenPackages :: (PackageFixedDeps pkg)-               => FakeMap-               -> PackageIndex pkg-               -> [(pkg, [UnitId])]-brokenPackages fakeMap index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing =-          [ pkg' | pkg' <- CD.flatDeps (depends pkg)-                 , isNothing (fakeLookupUnitId fakeMap index pkg') ]-  , not (null missing) ]---- | 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 :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)-                          => FakeMap-                          -> Bool-                          -> PackageIndex pkg-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies fakeMap indepGoals index  =-    concatMap (dependencyInconsistencies' fakeMap) subplans-  where-    subplans :: [PackageIndex pkg]-    subplans = rights $-                 map (dependencyClosure fakeMap index)-                     (rootSets fakeMap indepGoals index)---- | 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 :: (PackageFixedDeps pkg, HasUnitId pkg)-         => FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]]-rootSets fakeMap indepGoals index =-       if indepGoals then map (:[]) libRoots else [libRoots]-    ++ setupRoots index-  where-    libRoots = libraryRoots fakeMap 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 :: (PackageFixedDeps pkg, HasUnitId pkg)-             => FakeMap -> PackageIndex pkg -> [UnitId]-libraryRoots fakeMap index =-    map toPkgId roots-  where-    (graph, toPkgId, _) = dependencyGraph fakeMap index-    indegree = Graph.indegree graph-    roots    = filter isRoot (Graph.vertices graph)-    isRoot v = indegree ! v == 0---- | The setup dependencies of each package in the plan-setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]]-setupRoots = filter (not . null)-           . map (CD.setupDeps . depends)-           . allPackages---- | 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' :: forall pkg.-                              (PackageFixedDeps pkg, HasUnitId pkg)-                           => FakeMap-                           -> PackageIndex pkg-                           -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies' fakeMap 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 that package-    --     the associated package instance-    --     and a list of reverse dependencies (as source IDs)-    inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))-    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))-      [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])-      | -- For each package @pkg@-        pkg <- allPackages index-        -- Find out which @ipid@ @pkg@ depends on-      , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)-        -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)-      , Just dep <- [fakeLookupUnitId fakeMap index ipid]-      ]--    -- 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 :: [pkg] -> Bool-    reallyIsInconsistent []       = False-    reallyIsInconsistent [_p]     = False-    reallyIsInconsistent [p1, p2] =-      let pid1 = installedUnitId p1-          pid2 = installedUnitId p2-      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)-      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)-    reallyIsInconsistent _ = True------ | Find if there are any cycles in the dependency graph. If there are no--- cycles the result is @[]@.------ This actually computes the strongly connected components. So it gives us a--- list of groups of packages where within each group they all depend on each--- other, directly or indirectly.----dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)-                 => FakeMap-                 -> PackageIndex pkg-                 -> [[pkg]]-dependencyCycles fakeMap index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, installedUnitId pkg,-                            CD.flatDeps (fakeDepends fakeMap pkg))-                    | pkg <- allPackages index ]----- | Tries to take the transitive closure of the package dependencies.------ If the transitive closure is complete then it returns that subset of the--- index. Otherwise it returns the broken packages as in 'brokenPackages'.------ * Note that if the result is @Right []@ it is because at least one of--- the original given 'PackageIdentifier's do not occur in the index.-dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)-                  => FakeMap-                  -> PackageIndex pkg-                  -> [UnitId]-                  -> Either [(pkg, [UnitId])]-                            (PackageIndex pkg)-dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of-  (completed, []) -> Right completed-  (completed, _)  -> Left (brokenPackages fakeMap completed)- where-    closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) =-      case fakeLookupUnitId fakeMap index pkgid of-        Nothing   -> closure completed (pkgid:failed) pkgids-        Just pkg  ->-          case fakeLookupUnitId fakeMap completed-               (installedUnitId pkg) of-            Just _  -> closure completed  failed pkgids-            Nothing -> closure completed' failed pkgids'-              where completed' = insert pkg completed-                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids----- | Builds a graph of the package dependencies.------ Dependencies on other packages that are not in the index are discarded.--- You can check if there are any such dependencies with 'brokenPackages'.----dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)-                => FakeMap-                -> PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> UnitId,-                    UnitId -> Maybe Graph.Vertex)-dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)-  where-    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges-    vertexToPkg v = case vertexToPkg' v of-                      ((), pkgid, _targets) -> pkgid--    pkgs  = allPackages index-    edges = map edgesFrom pkgs--    resolve   pid = Map.findWithDefault pid pid fakeMap-    edgesFrom pkg = ( ()-                    , resolve (installedUnitId pkg)-                    , CD.flatDeps (fakeDepends fakeMap pkg)-                    )
Distribution/Client/ProjectBuilding.hs view
@@ -1,1292 +1,1328 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,-             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,-             ScopedTypeVariables #-}---- | ----module Distribution.Client.ProjectBuilding (-    BuildStatus(..),-    BuildStatusMap,-    BuildStatusRebuild(..),-    BuildReason(..),-    MonitorChangedReason(..),-    rebuildTargetsDryRun,-    rebuildTargets-  ) where--import           Distribution.Client.PackageHash (renderPackageHashInputs)-import           Distribution.Client.RebuildMonad-import           Distribution.Client.ProjectConfig-import           Distribution.Client.ProjectPlanning--import           Distribution.Client.Types-                   ( PackageLocation(..), GenericReadyPackage(..)-                   , PackageFixedDeps(..)-                   , InstalledPackageId, installedPackageId )-import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, GenericPlanPackage )-import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.ComponentDeps as CD-import           Distribution.Client.ComponentDeps (ComponentDeps)-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)-import           Distribution.Client.SrcDist (allPackageSourceFiles)-import           Distribution.Client.Utils (removeExistingFile)--import           Distribution.Package hiding (InstalledPackageId, installedPackageId)-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as Installed-import           Distribution.Simple.Program-import qualified Distribution.Simple.Setup as Cabal-import           Distribution.Simple.Command (CommandUI)-import qualified Distribution.Simple.Register as Cabal-import qualified Distribution.Simple.InstallDirs as InstallDirs-import           Distribution.Simple.LocalBuildInfo (ComponentName)--import           Distribution.Simple.Utils hiding (matchFileGlob)-import           Distribution.Version-import           Distribution.Verbosity-import           Distribution.Text-import           Distribution.ParseUtils ( showPWarning )--import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.ByteString.Lazy as LBS--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Monad-import           Control.Exception-import           Control.Concurrent.Async-import           Control.Concurrent.MVar-import           Data.List-import           Data.Maybe--import           System.FilePath-import           System.IO-import           System.Directory-import           System.Exit (ExitCode)------------------------------------------------------------------------------------ * Overall building strategy.------------------------------------------------------------------------------------- We start with an 'ElaboratedInstallPlan' that has already been improved by--- reusing packages from the store. 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.------------------------------------------------------------------------------------ * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?----------------------------------------------------------------------------------- We split things like this for a couple reasons. Firstly we need to be able--- to do dry runs, 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 sitation).----- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'----type BuildStatusMap = Map InstalledPackageId BuildStatus---- | The build status for an individual package. That is, the state that the--- package is in prior to initiating a (re)build.------ 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 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 (Maybe InstalledPackageInfo) BuildSuccess---- | 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 stil need to do that after building.-     ---   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason--data BuildReason =-     -- | The depencencies of this package have been (re)built so the build-     -- phase needs to be rerun.-     ---     -- The optional registration info here tells us if we've registered the-     -- package already, or if we stil need to do that after building.-     ---     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---- | 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 BuildStatusUpToDate {} = False-buildStatusRequiresBuild _                      = True---- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.------ It gives us the 'BuildStatusMap' and also gives us 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-                     -> ElaboratedInstallPlan-                     -> IO (ElaboratedInstallPlan, BuildStatusMap)-rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do--    -- Do the various checks to work out the 'BuildStatus' of each package-    pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg--    -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as-    -- 'InstallPlan.Installed'.-    let installPlan' = improveInstallPlanWithUpToDatePackages-                         installPlan pkgsBuildStatus--    return (installPlan', pkgsBuildStatus)-  where-    dryRunPkg :: ElaboratedPlanPackage-              -> ComponentDeps [BuildStatus]-              -> IO BuildStatus-    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =-      return BuildStatusPreExisting--    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do-      mloc <- checkFetched (pkgSourceLocation 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 three tarball cases are 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--    dryRunPkg (InstallPlan.Processing {}) _ = unexpectedState-    dryRunPkg (InstallPlan.Installed  {}) _ = unexpectedState-    dryRunPkg (InstallPlan.Failed     {}) _ = unexpectedState--    unexpectedState = error "rebuildTargetsDryRun: unexpected package state"--    dryRunTarballPkg :: ElaboratedConfiguredPackage-                     -> ComponentDeps [BuildStatus]-                     -> FilePath-                     -> IO BuildStatus-    dryRunTarballPkg pkg depsBuildStatus tarball =-      case pkgBuildStyle 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-                   -> ComponentDeps [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 (mipkg, buildSuccess) ->-            return (BuildStatusUpToDate mipkg buildSuccess)-      where-        packageFileMonitor =-          newPackageFileMonitor distDirLayout (packageId pkg)----- | A specialised traversal over the packages in an install plan.------ The packages are visited in dependency order, starting with packages with no--- depencencies. The result for each package is accumulated into a 'Map' and--- returned as the final result. In addition, when visting a package, the--- visiting function is passed the results for all the immediate package--- depencencies. This can be used to propagate information from depencencies.----foldMInstallPlanDepOrder-  :: forall m ipkg srcpkg iresult ifailure b.-     (Monad m,-      HasUnitId ipkg,   PackageFixedDeps ipkg,-      HasUnitId srcpkg, PackageFixedDeps srcpkg)-  => GenericInstallPlan ipkg srcpkg iresult ifailure-  -> (GenericPlanPackage ipkg srcpkg iresult ifailure ->-      ComponentDeps [b] -> m b)-  -> m (Map InstalledPackageId b)-foldMInstallPlanDepOrder plan0 visit =-    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)-  where-    go :: Map InstalledPackageId b-       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]-       -> m (Map InstalledPackageId 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 :: ComponentDeps [b]-          depresults =-            fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results-                                   in result))-                 (depends pkg)-      result <- visit pkg depresults-      let results' = Map.insert (installedPackageId pkg) result results-      go results' pkgs--improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan-                                       -> BuildStatusMap-                                       -> ElaboratedInstallPlan-improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =-    replaceWithPreInstalled installPlan-      [ (installedPackageId pkg, mipkg, buildSuccess)-      | InstallPlan.Configured pkg-          <- InstallPlan.reverseTopologicalOrder installPlan-      , let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus-      , BuildStatusUpToDate mipkg buildSuccess <- [pkgBuildStatus]-      ]-  where-    replaceWithPreInstalled =-      foldl' (\plan (ipkgid, mipkg, buildSuccess) ->-                InstallPlan.preinstalled ipkgid mipkg buildSuccess plan)----------------------------------- 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) BuildSuccess,-       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)-     }--newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor-newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =-    PackageFileMonitor {-      pkgFileMonitorConfig =-        newFileMonitor (distPackageCacheFile pkgid "config"),--      pkgFileMonitorBuild =-        FileMonitor {-          fileMonitorCacheFile = distPackageCacheFile pkgid "build",-          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->-            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,-          fileMonitorCheckIfOnlyValueChanged = True-        },--      pkgFileMonitorReg =-        newFileMonitor (distPackageCacheFile pkgid "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 pkg =-    (pkgconfig, 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.-    ---    pkgconfig = pkg {-      pkgBuildTargets  = [],-      pkgReplTarget    = Nothing,-      pkgBuildHaddocks = 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 = pkgBuildTargetWholeComponents pkg---- | Do all the checks on whether a package has changed and thus needs either--- rebuilding or reconfiguring and rebuilding.----checkPackageFileMonitorChanged :: PackageFileMonitor-                               -> ElaboratedConfiguredPackage-                               -> FilePath-                               -> ComponentDeps [BuildStatus]-                               -> IO (Either BuildStatusRebuild-                                            (Maybe InstalledPackageInfo,-                                             BuildSuccess))-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 depencencies.-        | any buildStatusRequiresBuild (CD.flatDeps 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 buildSuccess _, MonitorUnchanged mipkg _) ->-                return (Right (mipkg, buildSuccess))-  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-                              -> [FilePath]-                              -> BuildSuccess-                              -> IO ()-updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}-                              srcdir timestamp pkg pkgBuildStatus-                              allSrcFiles buildSuccess =-    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)-                      (map monitorFileHashed allSrcFiles)-                      buildComponents' buildSuccess-  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'------------------------------------------------------------------------------------ | Build things for real.------ It requires the 'BuildStatusMap' gatthered by 'rebuildTargetsDryRun'.----rebuildTargets :: Verbosity-               -> DistDirLayout-               -> ElaboratedInstallPlan-               -> ElaboratedSharedConfig-               -> BuildStatusMap-               -> BuildTimeSettings-               -> IO ElaboratedInstallPlan-rebuildTargets verbosity-               distDirLayout@DistDirLayout{..}-               installPlan-               sharedPackageConfig-               pkgsBuildStatus-               buildSettings@BuildTimeSettings{buildSettingNumJobs} = do--    -- Concurrency control: create the job controller and concurrency limits-    -- for downloading, building and installing.-    jobControl    <- if isParallelBuild then newParallelJobControl-                                        else newSerialJobControl-    buildLimit    <- newJobLimit buildSettingNumJobs-    installLock   <- newLock -- serialise installation-    cacheLock     <- newLock -- serialise access to setup exe cache-                             --TODO: [code cleanup] eliminate setup exe cache--    createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory-    createDirectoryIfMissingVerbose verbosity False distTempDirectory--    -- 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...-      executeInstallPlan verbosity jobControl installPlan $ \pkg ->-        handle (return . BuildFailure) $ --TODO: review exception handling--        let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in--        rebuildTarget-          verbosity-          distDirLayout-          buildSettings downloadMap-          buildLimit installLock cacheLock -          sharedPackageConfig-          pkg-          pkgBuildStatus-  where-    isParallelBuild = buildSettingNumJobs >= 2-    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity -                        buildSettings---- | Given all the context and resources, (re)build an individual package.----rebuildTarget :: Verbosity-              -> DistDirLayout-              -> BuildTimeSettings-              -> AsyncDownloadMap-              -> JobLimit -> Lock -> Lock-              -> ElaboratedSharedConfig-              -> ElaboratedReadyPackage-              -> BuildStatus-              -> IO BuildResult-rebuildTarget verbosity-              distDirLayout@DistDirLayout{distBuildDirectory}-              buildSettings downloadMap-              buildLimit installLock cacheLock-              sharedPackageConfig-              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-      BuildStatusUpToDate    {} -> unexpectedState-  where-    unexpectedState = error "rebuildTarget: unexpected package status"--    downloadPhase = do-        downsrcloc <- waitAsyncPackageDownload verbosity downloadMap pkg-        case downsrcloc of-          DownloadedTarball tarball -> unpackTarballPhase tarball-          --TODO: [nice to have] git/darcs repos etc---    unpackTarballPhase tarball =-      withJobLimit buildLimit $-        withTarballLocalDirectory-          verbosity distDirLayout tarball-          (packageId pkg) (pkgBuildStyle pkg)-          (pkgDescriptionOverride pkg) $--          case pkgBuildStyle 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 (pkgBuildStyle pkg == BuildInplaceOnly) $--        withJobLimit buildLimit $-          buildInplace buildStatus srcdir builddir-      where-        builddir = distBuildDirectory (packageId pkg)--    buildAndInstall srcdir builddir =-        buildAndInstallUnpackedPackage-          verbosity distDirLayout-          buildSettings installLock cacheLock-          sharedPackageConfig-          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 cacheLock-          sharedPackageConfig-          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?--type AsyncDownloadMap = Map (PackageLocation (Maybe FilePath))-                            (MVar DownloadedSourceLocation)--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---- | 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 ()) -> IO ())-                      -> ElaboratedInstallPlan-                      -> BuildStatusMap-                      -> (AsyncDownloadMap -> IO a)-                      -> IO a-asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body-  | null pkgsToDownload = body Map.empty-  | otherwise = do-    --TODO: [research required] use parallel downloads? if so, use the fetchLimit--    asyncDownloadVars <- mapM (\loc -> (,) loc <$> newEmptyMVar) pkgsToDownload--    let downloadAction :: IO ()-        downloadAction =-          withRepoCtx $ \repoctx ->-            forM_ asyncDownloadVars $ \(pkgloc, var) -> do-              Just scrloc <- downloadedSourceLocation <$>-                             fetchPackage verbosity repoctx pkgloc-              putMVar var scrloc--    withAsync downloadAction $ \_ ->-      body (Map.fromList asyncDownloadVars)-  where-    pkgsToDownload = -      [ pkgSourceLocation pkg-      | InstallPlan.Configured pkg-         <- InstallPlan.reverseTopologicalOrder installPlan-      , let ipkgid = installedPackageId pkg-            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus-      , BuildStatusDownload <- [pkgBuildStatus]-      ]----- | Check if a package needs downloading, and if so expect to find a download--- in progress in the given 'AsyncDownloadMap' and wait on it to finish.----waitAsyncPackageDownload :: Verbosity-                         -> AsyncDownloadMap-                         -> ElaboratedConfiguredPackage-                         -> IO DownloadedSourceLocation-waitAsyncPackageDownload verbosity downloadMap pkg =-    case Map.lookup (pkgSourceLocation pkg) downloadMap of-      Just hnd -> do-        debug verbosity $-          "Waiting for download of " ++ display (packageId pkg) ++ " to finish"-        --TODO: [required eventually] do the exception handling on download stuff-        takeMVar hnd-      Nothing ->-        fail "waitAsyncPackageDownload: package not being download"---executeInstallPlan-  :: forall ipkg srcpkg iresult.-     (HasUnitId ipkg,   PackageFixedDeps ipkg,-      HasUnitId srcpkg, PackageFixedDeps srcpkg)-  => Verbosity-  -> JobControl IO ( GenericReadyPackage srcpkg ipkg-                   , GenericBuildResult ipkg iresult BuildFailure )-  -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-  -> (    GenericReadyPackage srcpkg ipkg-       -> IO (GenericBuildResult ipkg iresult BuildFailure))-  -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)-executeInstallPlan verbosity jobCtl plan0 installPkg =-    tryNewTasks 0 plan0-  where-    tryNewTasks taskCount plan = do-      case InstallPlan.ready plan of-        [] | taskCount == 0 -> return plan-           | otherwise      -> waitForTasks taskCount plan-        pkgs                -> do-          sequence_-            [ do debug verbosity $ "Ready to install " ++ display pkgid-                 spawnJob jobCtl $ do-                   buildResult <- installPkg pkg-                   return (pkg, buildResult)-            | pkg <- pkgs-            , let pkgid = packageId pkg-            ]--          let taskCount' = taskCount + length pkgs-              plan'      = InstallPlan.processing pkgs plan-          waitForTasks taskCount' plan'--    waitForTasks taskCount plan = do-      debug verbosity $ "Waiting for install task to finish..."-      (pkg, buildResult) <- collectJob jobCtl-      let taskCount' = taskCount-1-          plan'      = updatePlan pkg buildResult plan-      tryNewTasks taskCount' plan'--    updatePlan :: GenericReadyPackage srcpkg ipkg-               -> GenericBuildResult ipkg iresult BuildFailure-               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure-    updatePlan pkg (BuildSuccess mipkg buildSuccess) =-        InstallPlan.completed (installedPackageId pkg) mipkg buildSuccess--    updatePlan pkg (BuildFailure buildFailure) =-        InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure-      where-        depsFailure = DependentFailed (packageId pkg)-        -- So this first pkgid failed for whatever reason (buildFailure).-        -- All the other packages that depended on this pkgid, which we-        -- now cannot build, we mark as failing due to 'DependentFailed'-        -- which kind of means it was not their fault.----- | 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-  -> BuildStyle-  -> Maybe CabalFileText-  -> (FilePath -> FilePath -> IO a)-  -> IO a-withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}-                          tarball pkgid buildstyle pkgTextOverride-                          buildPkg  =-      case buildstyle of-        -- In this case we make a temp dir, unpack the tarball to there and-        -- build and install it from that temp dir.-        BuildAndInstall ->-          withTempDirectory verbosity distTempDirectory-                            (display (packageName pkgid)) $ \tmpdir -> do-            unpackPackageTarball verbosity tarball tmpdir-                                 pkgid pkgTextOverride-            let srcdir   = tmpdir </> display 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 pkgid-          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test-          exists <- doesDirectoryExist srcdir-          unless exists $ do-            createDirectoryIfMissingVerbose verbosity False srcrootdir-            unpackPackageTarball verbosity tarball srcrootdir-                                 pkgid pkgTextOverride-            moveTarballShippedDistDirectory verbosity distDirLayout-                                            srcrootdir pkgid-          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-    annotateFailure UnpackFailed $ do--      -- Unpack the tarball-      ---      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."-      Tar.extractTarGzFile parentdir pkgsubdir tarball--      -- Sanity check-      ---      exists <- doesFileExist cabalFile-      when (not exists) $-        die $ "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 " ++ display pkgname <.> "cabal"-                        ++ " with the latest revision from the index."-          writeFileAtomic cabalFile pkgtxt--  where-    cabalFile = parentdir </> pkgsubdir-                          </> display pkgname <.> "cabal"-    pkgsubdir = display 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 -> IO ()-moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}-                                parentdir pkgid = 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 </> display pkgid </> "dist"-    targetDistDir  = distBuildDirectory pkgid---buildAndInstallUnpackedPackage :: Verbosity-                               -> DistDirLayout-                               -> BuildTimeSettings -> Lock -> Lock-                               -> ElaboratedSharedConfig-                               -> ElaboratedReadyPackage-                               -> FilePath -> FilePath-                               -> IO BuildResult-buildAndInstallUnpackedPackage verbosity-                               DistDirLayout{distTempDirectory}-                               BuildTimeSettings {-                                 buildSettingNumJobs,-                                 buildSettingLogFile-                               }-                               installLock cacheLock-                               pkgshared@ElaboratedSharedConfig {-                                 pkgConfigPlatform      = platform,-                                 pkgConfigCompiler      = compiler,-                                 pkgConfigCompilerProgs = progdb-                               }-                               rpkg@(ReadyPackage pkg _deps)-                               srcdir builddir = do--    createDirectoryIfMissingVerbose verbosity False 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-    when isParallelBuild $-      notice verbosity $ "Configuring " ++ display pkgid ++ "..."-    annotateFailure ConfigureFailed $-      setup configureCommand configureFlags--    -- Build phase-    when isParallelBuild $-      notice verbosity $ "Building " ++ display pkgid ++ "..."-    annotateFailure BuildFailed $-      setup buildCommand buildFlags--    -- Install phase-    mipkg <--      criticalSection installLock $ -      annotateFailure InstallFailed $ do-      --TODO: [research required] do we need the installLock for copying? can we not do that in-      -- parallel? Isn't it just registering that we have to lock for?--      --TODO: [required eventually] need to lock installing this ipkig so other processes don't-      -- stomp on our files, since we don't have ABI compat, not safe to replace--      -- 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.--      -- Actual installation-      setup Cabal.copyCommand copyFlags-      -      LBS.writeFile-        (InstallDirs.prefix (pkgInstallDirs pkg) </> "cabal-hash.txt") $-        (renderPackageHashInputs (packageHashInputs pkgshared pkg))--      -- here's where we could keep track of the installed files ourselves if-      -- we wanted by calling copy to an image dir and then we would make a-      -- manifest and move it to its final location--      --TODO: [nice to have] we should actually have it make an image in store/incomming and-      -- then when it's done, move it to its final location, to reduce problems-      -- with installs failing half-way. Could also register and then move.--      -- For libraries, grab the package configuration file-      -- and register it ourselves-      if pkgRequiresRegistration pkg-        then do-          ipkg <- 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' = ipkg { Installed.installedUnitId = ipkgid }-          Cabal.registerPackage verbosity compiler progdb-                                True -- multi-instance, nix style-                                (pkgRegisterPackageDBStack pkg) ipkg'-          return (Just ipkg')-        else return Nothing--    --TODO: [required feature] docs and test phases-    let docsResult  = DocsNotTried-        testsResult = TestsNotTried--    return (BuildSuccess mipkg (BuildOk docsResult testsResult))--  where-    pkgid  = packageId rpkg-    ipkgid = installedPackageId rpkg--    isParallelBuild = buildSettingNumJobs >= 2--    configureCommand = Cabal.configureCommand defaultProgramConfiguration-    configureFlags v = flip filterConfigureFlags v $-                       setupHsConfigureFlags rpkg pkgshared-                                             verbosity builddir--    buildCommand     = Cabal.buildCommand defaultProgramConfiguration-    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir--    generateInstalledPackageInfo :: IO InstalledPackageInfo-    generateInstalledPackageInfo =-      withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfFile -> do-        -- make absolute since setup changes dir-        pkgConfFile' <- canonicalizePath pkgConfFile-        let registerFlags _ = setupHsRegisterFlags-                                pkg pkgshared-                                verbosity builddir-                                pkgConfFile'-        setup Cabal.registerCommand registerFlags--    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir--    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir-                                         isParallelBuild cacheLock--    setup :: CommandUI flags -> (Version -> flags) -> IO ()-    setup cmd flags =-      withLogging $ \mLogFileHandle -> -        setupWrapper-          verbosity-          scriptOptions { useLoggingHandle = mLogFileHandle }-          (Just (pkgDescription pkg))-          cmd flags []--    mlogFile =-      case buildSettingLogFile of-        Nothing        -> Nothing-        Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid)--    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)---buildInplaceUnpackedPackage :: Verbosity-                            -> DistDirLayout-                            -> BuildTimeSettings -> Lock-                            -> ElaboratedSharedConfig-                            -> ElaboratedReadyPackage-                            -> BuildStatusRebuild-                            -> FilePath -> FilePath-                            -> IO BuildResult-buildInplaceUnpackedPackage verbosity-                            distDirLayout@DistDirLayout {-                              distTempDirectory,-                              distPackageCacheDirectory-                            }-                            BuildTimeSettings{buildSettingNumJobs}-                            cacheLock-                            pkgshared@ElaboratedSharedConfig {-                              pkgConfigCompiler      = compiler,-                              pkgConfigCompilerProgs = progdb-                            }-                            rpkg@(ReadyPackage pkg _deps)-                            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 False builddir-        createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid)-        createPackageDBIfMissing verbosity compiler progdb (pkgBuildPackageDBStack pkg)--        -- Configure phase-        ---        whenReConfigure $ do-          annotateFailure ConfigureFailed $-            setup configureCommand configureFlags []-          invalidatePackageRegFileMonitor packageFileMonitor-          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg--        -- Build phase-        ---        let docsResult  = DocsNotTried-            testsResult = TestsNotTried--            buildSuccess :: BuildSuccess-            buildSuccess = BuildOk docsResult testsResult--        whenRebuild $ do-          timestamp <- beginUpdateFileMonitor-          annotateFailure BuildFailed $-            setup buildCommand buildFlags buildArgs--          --TODO: [required eventually] this doesn't track file-          --non-existence, so we could fail to rebuild if someone-          --adds a new file which changes behavior.-          allSrcFiles <- allPackageSourceFiles verbosity srcdir--          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp-                                        pkg buildStatus-                                        allSrcFiles buildSuccess--        mipkg <- whenReRegister $ annotateFailure InstallFailed $ do-          -- Register locally-          mipkg <- if pkgRequiresRegistration pkg-            then do-                ipkg <- 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' = ipkg { Installed.installedUnitId = ipkgid }-                Cabal.registerPackage verbosity compiler progdb False-                                      (pkgRegisterPackageDBStack pkg)-                                      ipkg'-                return (Just ipkg')--           else return Nothing--          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg-          return mipkg--        -- Repl phase-        ---        whenRepl $-          annotateFailure BuildFailed $-          setup replCommand replFlags replArgs--        -- Haddock phase-        whenHaddock $-          annotateFailure BuildFailed $-          setup haddockCommand haddockFlags []--        return (BuildSuccess mipkg buildSuccess)--  where-    pkgid  = packageId rpkg-    ipkgid = installedPackageId rpkg--    isParallelBuild = buildSettingNumJobs >= 2--    packageFileMonitor = newPackageFileMonitor distDirLayout pkgid--    whenReConfigure action = case buildStatus of-      BuildStatusConfigure _ -> action-      _                      -> return ()--    whenRebuild action-      | null (pkgBuildTargets pkg) = return ()-      | otherwise                  = action--    whenRepl action-      | isNothing (pkgReplTarget pkg) = return ()-      | otherwise                     = action--    whenHaddock action-      | pkgBuildHaddocks pkg = action-      | otherwise            = return ()--    whenReRegister  action = case buildStatus of-      BuildStatusConfigure          _ -> action-      BuildStatusBuild Nothing      _ -> action-      BuildStatusBuild (Just mipkg) _ -> return mipkg--    configureCommand = Cabal.configureCommand defaultProgramConfiguration-    configureFlags v = flip filterConfigureFlags v $-                       setupHsConfigureFlags rpkg pkgshared-                                             verbosity builddir--    buildCommand     = Cabal.buildCommand defaultProgramConfiguration-    buildFlags   _   = setupHsBuildFlags pkg pkgshared-                                         verbosity builddir-    buildArgs        = setupHsBuildArgs  pkg--    replCommand      = Cabal.replCommand defaultProgramConfiguration-    replFlags _      = setupHsReplFlags pkg pkgshared-                                        verbosity builddir-    replArgs         = setupHsReplArgs  pkg--    haddockCommand   = Cabal.haddockCommand-    haddockFlags _   = setupHsHaddockFlags pkg pkgshared-                                           verbosity builddir--    scriptOptions    = setupHsScriptOptions rpkg pkgshared-                                            srcdir builddir-                                            isParallelBuild cacheLock--    setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()-    setup cmd flags args =-      setupWrapper verbosity-                   scriptOptions-                   (Just (pkgDescription pkg))-                   cmd flags args--    generateInstalledPackageInfo :: IO InstalledPackageInfo-    generateInstalledPackageInfo =-      withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfFile -> do-        -- make absolute since setup changes dir-        pkgConfFile' <- canonicalizePath pkgConfFile-        let registerFlags _ = setupHsRegisterFlags-                                pkg pkgshared-                                verbosity builddir-                                pkgConfFile'-        setup Cabal.registerCommand registerFlags []----- helper-annotateFailure :: (String -> BuildFailure) -> IO a -> IO a-annotateFailure annotate action =-  action `catches`-    [ Handler $ \ioe  -> handler (ioe  :: IOException)-    , Handler $ \exit -> handler (exit :: ExitCode)-    ]-  where-    handler :: Exception e => e -> IO a-    handler = throwIO . annotate-#if MIN_VERSION_base(4,8,0)-            . displayException-#else-            . show-#endif---withTempInstalledPackageInfoFile :: Verbosity -> FilePath-                                 -> (FilePath -> IO ())-                                 -> IO InstalledPackageInfo-withTempInstalledPackageInfoFile verbosity tempdir action =-    withTempFile tempdir "package-registration-" $ \pkgConfFile hnd -> do-      hClose hnd-      action pkgConfFile--      (warns, ipkg) <- withUTF8FileContents pkgConfFile $ \pkgConfStr ->-        case Installed.parseInstalledPackageInfo pkgConfStr of-          Installed.ParseFailed perror -> pkgConfParseFailed perror-          Installed.ParseOk warns ipkg -> return (warns, ipkg)--      unless (null warns) $-        warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)--      return ipkg-  where-    pkgConfParseFailed :: Installed.PError -> IO a-    pkgConfParseFailed perror =-      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"-            ++ show perror+             ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE ConstraintKinds #-}++-- |+--+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.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)+import           Distribution.Client.SourceFiles+import           Distribution.Client.SrcDist (allPackageSourceFiles)+import           Distribution.Client.Utils (removeExistingFile)++import           Distribution.Package hiding (InstalledPackageId, installedPackageId)+import qualified Distribution.PackageDescription as PD+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as Installed+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Types.BuildType+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)+import           Distribution.Simple.Compiler+                   ( Compiler, compilerId, PackageDB(..) )++import           Distribution.Simple.Utils hiding (matchFileGlob)+import           Distribution.Version+import           Distribution.Verbosity+import           Distribution.Text+import           Distribution.ParseUtils ( showPWarning )+import           Distribution.Compat.Graph (IsNode(..))++import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy as LBS++import           Control.Monad+import           Control.Exception+import           Data.Maybe++import           System.FilePath+import           System.IO+import           System.Directory+++------------------------------------------------------------------------------+-- * 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 three tarball cases are 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++    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 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 visting 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 Just result = Map.lookup 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: "+                        ++ display (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 :: DistDirLayout -> DistDirParams -> PackageFileMonitor+newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =+    PackageFileMonitor {+      pkgFileMonitorConfig =+        newFileMonitor (distPackageCacheFile dparams "config"),++      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   = [],+            elabReplTarget    = Nothing,+            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+    mapM_ (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+            Just pkgBuildStatus = Map.lookup 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+          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+            Just pkgBuildStatus = Map.lookup 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 </> display 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+      when (not 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 " ++ display pkgname <.> "cabal"+                        ++ " with the latest revision from the index."+          writeFileAtomic cabalFile pkgtxt++  where+    cabalFile = parentdir </> pkgsubdir+                          </> display pkgname <.> "cabal"+    pkgsubdir = display 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 </> display pkgid </> "dist"+    targetDistDir  = distBuildDirectory dparams+++buildAndInstallUnpackedPackage :: Verbosity+                               -> DistDirLayout+                               -> StoreDirLayout+                               -> BuildTimeSettings -> Lock -> Lock+                               -> ElaboratedSharedConfig+                               -> ElaboratedReadyPackage+                               -> FilePath -> FilePath+                               -> IO BuildResult+buildAndInstallUnpackedPackage verbosity+                               DistDirLayout{distTempDirectory}+                               storeDirLayout@StoreDirLayout {+                                 storePackageDBStack+                               }+                               BuildTimeSettings {+                                 buildSettingNumJobs,+                                 buildSettingLogFile+                               }+                               registerLock cacheLock+                               pkgshared@ElaboratedSharedConfig {+                                 pkgConfigPlatform      = platform,+                                 pkgConfigCompiler      = compiler,+                                 pkgConfigCompilerProgs = progdb+                               }+                               rpkg@(ReadyPackage pkg)+                               srcdir builddir = do++    createDirectoryIfMissingVerbose verbosity True 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++    let dispname = case elabPkgOrComp pkg of+            ElabPackage _ -> display pkgid+                ++ " (all, legacy fallback)"+            ElabComponent comp -> display pkgid+                ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")"++    -- Configure phase+    when isParallelBuild $+      notice verbosity $ "Configuring " ++ dispname ++ "..."+    annotateFailure mlogFile ConfigureFailed $+      setup' configureCommand configureFlags configureArgs++    -- Build phase+    when isParallelBuild $+      notice verbosity $ "Building " ++ dispname ++ "..."+    annotateFailure mlogFile BuildFailed $+      setup buildCommand buildFlags++    -- Install phase+    annotateFailure mlogFile InstallFailed $ do++      let copyPkgFiles tmpDir = do+            setup Cabal.copyCommand (copyFlags tmpDir)+            -- 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   = dropDrive (InstallDirs.prefix (elabInstallDirs pkg))+                entryDir = tmpDir </> prefix+            LBS.writeFile+              (entryDir </> "cabal-hash.txt")+              (renderPackageHashInputs (packageHashInputs pkgshared pkg))+            -- 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++          registerPkg+            | not (elabRequiresRegistration pkg) =+              debug verbosity $+                "registerPkg: elab does NOT require registration for " ++ display 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++    return BuildResult {+       buildResultDocs    = docsResult,+       buildResultTests   = testsResult,+       buildResultLogFile = mlogFile+    }++  where+    pkgid  = packageId rpkg+    uid    = installedUnitId rpkg+    compid = compilerId compiler++    isParallelBuild = buildSettingNumJobs >= 2++    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++    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 pkgshared srcdir builddir+                                         isParallelBuild cacheLock++    setup :: CommandUI flags -> (Version -> flags) -> IO ()+    setup cmd flags = setup' cmd flags []++    setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()+    setup' cmd flags args =+      withLogging $ \mLogFileHandle ->+        setupWrapper+          verbosity+          scriptOptions { useLoggingHandle = mLogFileHandle }+          (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)+++buildInplaceUnpackedPackage :: Verbosity+                            -> DistDirLayout+                            -> BuildTimeSettings -> Lock -> Lock+                            -> ElaboratedSharedConfig+                            -> ElaboratedInstallPlan+                            -> ElaboratedReadyPackage+                            -> BuildStatusRebuild+                            -> FilePath -> FilePath+                            -> IO BuildResult+buildInplaceUnpackedPackage verbosity+                            distDirLayout@DistDirLayout {+                              distTempDirectory,+                              distPackageCacheDirectory+                            }+                            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 scriptOptions srcdir+              ifNullThen m m' = do xs <- m+                                   if null xs then m' else return xs+          monitors <- case PD.buildType (elabPkgDescription pkg) of+            Just 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++        -- Repl phase+        --+        whenRepl $+          annotateFailureNoLog ReplFailed $+          setupInteractive replCommand replFlags replArgs++        -- Haddock phase+        whenHaddock $+          annotateFailureNoLog HaddocksFailed $+          setup haddockCommand haddockFlags []++        return BuildResult {+          buildResultDocs    = docsResult,+          buildResultTests   = testsResult,+          buildResultLogFile = Nothing+        }++  where+    ipkgid  = installedUnitId pkg+    dparams = elabDistDirParams pkgshared pkg++    isParallelBuild = buildSettingNumJobs >= 2++    packageFileMonitor = newPackageFileMonitor distDirLayout dparams++    whenReConfigure action = case buildStatus of+      BuildStatusConfigure _ -> action+      _                      -> return ()++    whenRebuild action+      | null (elabBuildTargets pkg)+      -- NB: we have to build the test suite!+      , null (elabTestTargets pkg) = return ()+      | otherwise                   = action++    whenTest action+      | null (elabTestTargets pkg) = return ()+      | otherwise                  = action++    whenRepl action+      | isNothing (elabReplTarget pkg) = return ()+      | otherwise                     = action++    whenHaddock action+      | elabBuildHaddocks 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    _   = setupHsTestFlags pkg pkgshared+                                         verbosity builddir+    testArgs         = setupHsTestArgs  pkg++    replCommand      = Cabal.replCommand defaultProgramDb+    replFlags _      = setupHsReplFlags pkg pkgshared+                                        verbosity builddir+    replArgs         = setupHsReplArgs  pkg++    haddockCommand   = Cabal.haddockCommand+    haddockFlags _   = setupHsHaddockFlags pkg pkgshared+                                           verbosity builddir++    scriptOptions    = setupHsScriptOptions rpkg pkgshared+                                            srcdir builddir+                                            isParallelBuild cacheLock++    setupInteractive :: CommandUI flags+                     -> (Version -> flags) -> [String] -> IO ()+    setupInteractive cmd flags args =+      setupWrapper verbosity+                   scriptOptions { isInteractive = True }+                   (Just (elabPkgDescription pkg))+                   cmd flags args++    setup :: CommandUI flags -> (Version -> flags) -> [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 []++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 :: Installed.PError -> IO a+    pkgConfParseFailed perror =+      die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+            ++ show perror++    readPkgConf pkgConfDir pkgConfFile = do+      (warns, ipkg) <- withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->+        case Installed.parseInstalledPackageInfo pkgConfStr of+          Installed.ParseFailed perror -> pkgConfParseFailed perror+          Installed.ParseOk warns ipkg -> return (warns, ipkg)++      unless (null warns) $+        warn verbosity $ unlines (map (showPWarning pkgConfFile) 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 view
@@ -0,0 +1,206 @@+{-# 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.Types          (DocsResult, TestsResult)+import Distribution.Client.FileMonitor    (MonitorChangedReason(..))++import Distribution.Package               (UnitId, PackageId)+import Distribution.InstalledPackageInfo  (InstalledPackageInfo)+import Distribution.Simple.LocalBuildInfo (ComponentName)++import Data.Map          (Map)+import Data.Set          (Set)+import Data.Typeable     (Typeable)+import Control.Exception (Exception, SomeException)+++------------------------------------------------------------------------------+-- 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+                        | InstallFailed   SomeException+  deriving Show+
Distribution/Client/ProjectConfig.hs view
@@ -8,14 +8,21 @@     ProjectConfig(..),     ProjectConfigBuildOnly(..),     ProjectConfigShared(..),+    ProjectConfigProvenance(..),     PackageConfig(..),     MapLast(..),     MapMappend(..), -    -- * Project config files+    -- * Project root     findProjectRoot,+    ProjectRoot(..),+    BadProjectRoot(..),++    -- * Project config files     readProjectConfig,+    readProjectLocalFreezeConfig,     writeProjectLocalExtraConfig,+    writeProjectLocalFreezeConfig,     writeProjectConfigFile,     commandLineFlagsToProjectConfig, @@ -41,6 +48,9 @@     BadPerPackageCompilerPaths(..)   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectConfig.Legacy import Distribution.Client.RebuildMonad@@ -49,36 +59,47 @@  import Distribution.Client.Types import Distribution.Client.DistDirLayout-         ( CabalDirLayout(..) )+         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) import Distribution.Client.GlobalFlags          ( RepoContext(..), withRepoContext' ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Config          ( loadConfig, defaultConfigFile )+import Distribution.Client.IndexUtils.Timestamp+         ( IndexState(..) ) +import Distribution.Solver.Types.SourcePackage+import Distribution.Solver.Types.Settings+ import Distribution.Package-         ( PackageName, PackageId, packageId, UnitId, Dependency )+         ( PackageName, PackageId, packageId, UnitId )+import Distribution.Types.Dependency import Distribution.System          ( Platform ) import Distribution.PackageDescription          ( SourceRepo(..) )+#if CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+#else import Distribution.PackageDescription.Parse-         ( readPackageDescription )+         ( readGenericPackageDescription )+#endif import Distribution.Simple.Compiler          ( Compiler, compilerInfo ) import Distribution.Simple.Program          ( ConfiguredProgram(..) ) import Distribution.Simple.Setup          ( Flag(Flag), toFlag, flagToMaybe, flagToList-         , fromFlag, AllowNewer(..) )+         , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup-         ( defaultSolver, defaultMaxBackjumps, )+         ( defaultSolver, defaultMaxBackjumps ) import Distribution.Simple.InstallDirs          ( PathTemplate, fromPathTemplate          , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils-         ( die, warn )+         ( die', warn ) import Distribution.Client.Utils          ( determineNumJobs ) import Distribution.Utils.NubList@@ -89,19 +110,14 @@ import Distribution.ParseUtils          ( ParseResult(..), locatedErrorMsg, showPWarning ) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception-import Data.Typeable import Data.Maybe import Data.Either import qualified Data.Map as Map-import Data.Map (Map)+import Data.Set (Set) import qualified Data.Set as Set-import Distribution.Compat.Semigroup import System.FilePath hiding (combine) import System.Directory import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)@@ -149,18 +165,18 @@ -- to the 'BuildTimeSettings' -- projectConfigWithSolverRepoContext :: Verbosity-                                   -> FilePath                                    -> ProjectConfigShared                                    -> ProjectConfigBuildOnly                                    -> (RepoContext -> IO a) -> IO a-projectConfigWithSolverRepoContext verbosity downloadCacheRootDir+projectConfigWithSolverRepoContext verbosity                                    ProjectConfigShared{..}                                    ProjectConfigBuildOnly{..} =     withRepoContext'       verbosity       (fromNubList projectConfigRemoteRepos)       (fromNubList projectConfigLocalRepos)-      downloadCacheRootDir+      (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir")+                         projectConfigCacheDir)       (flagToMaybe projectConfigHttpTransport)       (flagToMaybe projectConfigIgnoreExpiry) @@ -187,12 +203,16 @@                                           (getMapMappend projectConfigSpecificPackage)     solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion     solverSettingSolver            = fromFlag projectConfigSolver+    solverSettingAllowOlder        = fromJust projectConfigAllowOlder     solverSettingAllowNewer        = fromJust projectConfigAllowNewer     solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of                                        n | n < 0     -> Nothing                                          | otherwise -> Just n     solverSettingReorderGoals      = fromFlag projectConfigReorderGoals+    solverSettingCountConflicts    = fromFlag projectConfigCountConflicts     solverSettingStrongFlags       = fromFlag projectConfigStrongFlags+    solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls+    solverSettingIndexState        = fromFlagOrDefault IndexStateHead projectConfigIndexState   --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs   --solverSettingReinstall         = fromFlag projectConfigReinstall@@ -204,11 +224,14 @@      defaults = mempty {        projectConfigSolver            = Flag defaultSolver,-       projectConfigAllowNewer        = Just AllowNewerNone,+       projectConfigAllowOlder        = Just (AllowOlder RelaxDepsNone),+       projectConfigAllowNewer        = Just (AllowNewer RelaxDepsNone),        projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,-       projectConfigReorderGoals      = Flag False,-       projectConfigStrongFlags       = Flag False-     --projectConfigIndependentGoals  = Flag False,+       projectConfigReorderGoals      = Flag (ReorderGoals False),+       projectConfigCountConflicts    = Flag (CountConflicts True),+       projectConfigStrongFlags       = Flag (StrongFlags False),+       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False)+     --projectConfigIndependentGoals  = Flag (IndependentGoals False),      --projectConfigShadowPkgs        = Flag False,      --projectConfigReinstall         = Flag False,      --projectConfigAvoidReinstalls   = Flag False,@@ -222,52 +245,50 @@ -- resolveBuildTimeSettings :: Verbosity                          -> CabalDirLayout-                         -> ProjectConfigShared-                         -> ProjectConfigBuildOnly-                         -> ProjectConfigBuildOnly+                         -> ProjectConfig                          -> BuildTimeSettings resolveBuildTimeSettings verbosity                          CabalDirLayout {-                           cabalLogsDirectory,-                           cabalPackageCacheDirectory-                         }-                         ProjectConfigShared {-                           projectConfigRemoteRepos,-                           projectConfigLocalRepos+                           cabalLogsDirectory                          }-                         fromProjectFile-                         fromCommandLine =+                         ProjectConfig {+                           projectConfigShared = ProjectConfigShared {+                             projectConfigRemoteRepos,+                             projectConfigLocalRepos+                           },+                           projectConfigBuildOnly+                         } =     BuildTimeSettings {..}   where     buildSettingDryRun        = fromFlag    projectConfigDryRun     buildSettingOnlyDeps      = fromFlag    projectConfigOnlyDeps     buildSettingSummaryFile   = fromNubList projectConfigSummaryFile-    --buildSettingLogFile       -- defined below, more complicated +    --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     buildSettingLocalRepos    = fromNubList projectConfigLocalRepos-    buildSettingCacheDir      = cabalPackageCacheDirectory+    buildSettingCacheDir      = fromFlag    projectConfigCacheDir     buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport     buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry     buildSettingReportPlanningFailure                               = fromFlag projectConfigReportPlanningFailure-    buildSettingRootCmd       = flagToMaybe projectConfigRootCmd      ProjectConfigBuildOnly{..} = defaults-                              <> fromProjectFile-                              <> fromCommandLine+                              <> 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,@@ -288,7 +309,8 @@       | otherwise          = fmap  substLogFileName givenTemplate      defaultTemplate = toPathTemplate $-                        cabalLogsDirectory </> "$pkgid" <.> "log"+                        cabalLogsDirectory </>+                        "$compiler" </> "$libname" <.> "log"     givenTemplate   = flagToMaybe projectConfigLogFile      useDefaultTemplate@@ -332,58 +354,104 @@ -- 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 :: IO FilePath-findProjectRoot = do+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)) -    curdir  <- getCurrentDirectory-    homedir <- getHomeDirectory+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-    let probe dir | isDrive dir || dir == homedir-                  = return curdir -- implicit project root-        probe dir = do-          exists <- doesFileExist (dir </> "cabal.project")+    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 dir       -- explicit project root-            else probe (takeDirectory dir)+            then return (Right (ProjectRootExplicit dir projectFileName))+            else go (takeDirectory dir) -    probe curdir    --TODO: [nice to have] add compat support for old style sandboxes  +-- | 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."++ -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. ---readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig-readProjectConfig verbosity projectRootDir = do-    global <- readGlobalConfig verbosity-    local  <- readProjectLocalConfig      verbosity projectRootDir-    extra  <- readProjectLocalExtraConfig verbosity projectRootDir-    return (global <> local <> extra)+readProjectConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig+readProjectConfig verbosity distDirLayout = do+    global <- readGlobalConfig             verbosity+    local  <- readProjectLocalConfig       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. ---readProjectLocalConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig-readProjectLocalConfig verbosity projectRootDir = do+readProjectLocalConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig+readProjectLocalConfig verbosity DistDirLayout{distProjectFile} = do   usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile   if usesExplicitProjectRoot     then do       monitorFiles [monitorFileHashed projectFile]-      liftIO readProjectFile+      addProjectFileProvenance <$> liftIO readProjectFile     else do       monitorFiles [monitorNonExistentFile projectFile]       return defaultImplicitProjectConfig    where-    projectFile = projectRootDir </> "cabal.project"+    projectFile = distProjectFile ""     readProjectFile =           reportParseResult verbosity "project file" projectFile         . parseProjectConfig       =<< readFile projectFile +    addProjectFileProvenance config =+      config {+        projectConfigProvenance =+          Set.insert (Explicit projectFile) (projectConfigProvenance config)+      }+     defaultImplicitProjectConfig :: ProjectConfig     defaultImplicitProjectConfig =       mempty {@@ -391,30 +459,50 @@         projectPackages         = [ "./*.cabal" ],          -- This is to automatically pick up deps that we unpack locally.-        projectPackagesOptional = [ "./*/*.cabal" ]-      }+        projectPackagesOptional = [ "./*/*.cabal" ], +        projectConfigProvenance = Set.singleton Implicit+      } --- | Reads a @cabal.project.extra@ file in the given project root dir,+-- | 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 -> FilePath -> Rebuild ProjectConfig-readProjectLocalExtraConfig verbosity projectRootDir = do-    hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile-    if hasExtraConfig-      then do monitorFiles [monitorFileHashed projectExtraConfigFile]-              liftIO readProjectExtraConfigFile-      else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]+readProjectLocalExtraConfig :: Verbosity -> DistDirLayout+                            -> Rebuild ProjectConfig+readProjectLocalExtraConfig verbosity distDirLayout =+    readProjectExtensionFile 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 =+    readProjectExtensionFile verbosity distDirLayout "freeze"+                             "project freeze file"++-- | Reads a named config file in the given project root dir, or returns empty.+--+readProjectExtensionFile :: Verbosity -> DistDirLayout -> String -> FilePath+                         -> Rebuild ProjectConfig+readProjectExtensionFile verbosity DistDirLayout{distProjectFile}+                         extensionName extensionDescription = do+    exists <- liftIO $ doesFileExist extensionFile+    if exists+      then do monitorFiles [monitorFileHashed extensionFile]+              liftIO readExtensionFile+      else do monitorFiles [monitorNonExistentFile extensionFile]               return mempty   where-    projectExtraConfigFile = projectRootDir </> "cabal.project.local"+    extensionFile = distProjectFile extensionName -    readProjectExtraConfigFile =-          reportParseResult verbosity "project local configuration file"-                            projectExtraConfigFile+    readExtensionFile =+          reportParseResult verbosity extensionDescription extensionFile         . parseProjectConfig-      =<< readFile projectExtraConfigFile+      =<< readFile extensionFile   -- | Parse the 'ProjectConfig' format.@@ -438,15 +526,20 @@     showLegacyProjectConfig . convertToLegacyProjectConfig  --- | Write a @cabal.project.extra@ file in the given project root dir.+-- | Write a @cabal.project.local@ file in the given project root dir. ---writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO ()-writeProjectLocalExtraConfig projectRootDir =-    writeProjectConfigFile projectExtraConfigFile-  where-    projectExtraConfigFile = projectRootDir </> "cabal.project.local"+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 ()@@ -472,9 +565,9 @@       let msg = unlines (map (showPWarning filename) warnings)        in warn verbosity msg     return x-reportParseResult _verbosity filetype filename (ParseFailed err) =+reportParseResult verbosity filetype filename (ParseFailed err) =     let (line, msg) = locatedErrorMsg err-     in die $ "Error parsing " ++ filetype ++ " " ++ filename+     in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename            ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg  @@ -498,11 +591,21 @@  -- | Exception thrown by 'findProjectPackages'. ---newtype BadPackageLocations = BadPackageLocations [BadPackageLocation]+data BadPackageLocations+   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]+#if MIN_VERSION_base(4,8,0)   deriving (Show, Typeable)+#else+  deriving (Typeable) -instance Exception BadPackageLocations---TODO: [required eventually] displayException for nice rendering+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@@ -521,14 +624,104 @@    | 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 --- | Given the project config, +      -- 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 :: FilePath -> ProjectConfig+findProjectPackages :: DistDirLayout -> ProjectConfig                     -> Rebuild [ProjectPackageLocation]-findProjectPackages projectRootDir ProjectConfig{..} = do+findProjectPackages DistDirLayout{distProjectRootDirectory}+                    ProjectConfig{..} = do      requiredPkgs <- findPackageLocations True    projectPackages     optionalPkgs <- findPackageLocations False   projectPackagesOptional@@ -541,7 +734,7 @@       (problems, pkglocs) <-         partitionEithers <$> mapM (findPackageLocation required) pkglocstr       unless (null problems) $-        liftIO $ throwIO $ BadPackageLocations problems+        liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems       return (concat pkglocs)  @@ -580,6 +773,10 @@           | recognisedScheme && not (null host) ->             Just (Right [ProjectPackageRemoteTarball uri]) +          --TODO: [required eventually] handle file: urls which do have a null+          -- host. translate URI into filepath and use ProjectPackageLocalTarball+          -- or keep as file url and use ProjectPackageRemoteTarball?+           | not recognisedScheme && not (null host) ->             Just (Left (BadLocUnexpectedUriScheme pkglocstr)) @@ -599,7 +796,7 @@           matches <- matchFileGlob glob           case matches of             [] | isJust (isTrivialFilePathGlob glob)-               -> return (Left (BadPackageLocationFile +               -> return (Left (BadPackageLocationFile                                   (BadLocNonexistantFile pkglocstr)))              [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))@@ -607,13 +804,15 @@             _  -> do               (failures, pkglocs) <- partitionEithers <$>                                      mapM checkFilePackageMatch matches-              if null pkglocs-                then return (Left (BadLocGlobBadMatches pkglocstr failures))-                else return (Right pkglocs)+              return $! case (failures, pkglocs) of+                ([failure], []) | isJust (isTrivialFilePathGlob glob)+                        -> Left (BadPackageLocationFile failure)+                (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)+                _       -> Right pkglocs       checkIsSingleFilePackage pkglocstr = do-      let filename = projectRootDir </> pkglocstr+      let filename = distProjectRootDirectory </> pkglocstr       isFile <- liftIO $ doesFileExist filename       isDir  <- liftIO $ doesDirectoryExist filename       if isFile || isDir@@ -629,7 +828,8 @@       -- 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 = projectRootDir </> pkglocstr+      let abspath = distProjectRootDirectory </> pkglocstr+      isFile <- liftIO $ doesFileExist abspath       isDir  <- liftIO $ doesDirectoryExist abspath       parentDirExists <- case takeDirectory abspath of                            []  -> return False@@ -650,6 +850,9 @@           | takeExtension pkglocstr == ".cabal"          -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) +          | isFile+         -> return (Left (BadLocUnexpectedFile pkglocstr))+           | parentDirExists          -> return (Left (BadLocNonexistantFile pkglocstr)) @@ -691,7 +894,7 @@ -- paths. -- readSourcePackage :: Verbosity -> ProjectPackageLocation-                  -> Rebuild SourcePackage+                  -> Rebuild UnresolvedSourcePackage readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =     readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile)   where@@ -700,7 +903,7 @@ readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do     monitorFiles [monitorFileHashed cabalFile]     root <- askRoot-    pkgdesc <- liftIO $ readPackageDescription verbosity (root </> cabalFile)+    pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root </> cabalFile)     return SourcePackage {       packageInfoId        = packageId pkgdesc,       packageDescription   = pkgdesc,@@ -718,12 +921,34 @@  data BadPerPackageCompilerPaths    = BadPerPackageCompilerPaths [(PackageName, String)]+#if MIN_VERSION_base(4,8,0)   deriving (Show, Typeable)+#else+  deriving (Typeable) -instance Exception BadPerPackageCompilerPaths---TODO: [required eventually] displayException for nice rendering+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 '"+ ++ display 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.@@ -744,4 +969,3 @@          , progname `Set.member` compProgNames ] of       [] -> return ()       ps -> throwIO (BadPerPackageCompilerPaths ps)-
Distribution/Client/ProjectConfig/Legacy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveGeneric #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric #-}  -- | Project configuration, implementation in terms of legacy types. --@@ -20,17 +20,21 @@     renderPackageLocationToken,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types          ( RemoteRepo(..), emptyRemoteRepo )-import Distribution.Client.Dependency.Types-         ( ConstraintSource(..) ) import Distribution.Client.Config          ( SavedConfig(..), remoteRepoFields ) +import Distribution.Solver.Types.ConstraintSource+ import Distribution.Package import Distribution.PackageDescription-         ( SourceRepo(..), RepoKind(..) )+         ( SourceRepo(..), RepoKind(..) +         , dispFlagAssignment, parseFlagAssignment ) import Distribution.PackageDescription.Parse          ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler@@ -39,8 +43,8 @@          ( Flag(Flag), toFlag, fromFlagOrDefault          , ConfigFlags(..), configureOptions          , HaddockFlags(..), haddockOptions, defaultHaddockFlags-         , programConfigurationPaths', splitArgs-         , AllowNewer(..) )+         , programDbPaths', splitArgs+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags@@ -49,8 +53,6 @@          ( programName, knownPrograms ) import Distribution.Simple.Program.Db          ( ProgramDb, defaultProgramDb )-import Distribution.Client.Targets-         ( dispFlagAssignment, parseFlagAssignment ) import Distribution.Simple.Utils          ( lowercase ) import Distribution.Utils.NubList@@ -76,14 +78,7 @@          ( CommandUI(commandOptions), ShowOrParseArgs(..)          , OptionField, option, reqArg' ) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad import qualified Data.Map as Map-import Data.Char (isSpace)-import Distribution.Compat.Semigroup-import GHC.Generics (Generic)  ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types@@ -242,6 +237,7 @@        projectConfigBuildOnly       = configBuildOnly,       projectConfigShared          = configAllPackages,+      projectConfigProvenance      = mempty,       projectConfigLocalPackages   = configLocalPackages,       projectConfigSpecificPackage = fmap perPackage legacySpecificConfig     }@@ -279,12 +275,14 @@     } = globalFlags      ConfigFlags {+      configDistPref            = projectConfigDistDir,       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,       configHcPkg               = projectConfigHcPkg,     --configInstallDirs         = projectConfigInstallDirs,     --configUserInstall         = projectConfigUserInstall,     --configPackageDBs          = projectConfigPackageDBs,+      configAllowOlder          = projectConfigAllowOlder,       configAllowNewer          = projectConfigAllowNewer     } = configFlags @@ -296,16 +294,21 @@     } = configExFlags      InstallFlags {+      installProjectFileName    = projectConfigProjectFile,       installHaddockIndex       = projectConfigHaddockIndex,     --installReinstall          = projectConfigReinstall,     --installAvoidReinstalls    = projectConfigAvoidReinstalls,     --installOverrideReinstall  = projectConfigOverrideReinstall,+      installIndexState         = projectConfigIndexState,       installMaxBackjumps       = projectConfigMaxBackjumps,     --installUpgradeDeps        = projectConfigUpgradeDeps,       installReorderGoals       = projectConfigReorderGoals,+      installCountConflicts     = projectConfigCountConflicts,+      installPerComponent       = projectConfigPerComponent,     --installIndependentGoals   = projectConfigIndependentGoals,     --installShadowPkgs         = projectConfigShadowPkgs,-      installStrongFlags        = projectConfigStrongFlags+      installStrongFlags        = projectConfigStrongFlags,+      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls     } = installFlags  @@ -364,6 +367,7 @@       haddockHoogle             = packageConfigHaddockHoogle,       haddockHtml               = packageConfigHaddockHtml,       haddockHtmlLocation       = packageConfigHaddockHtmlLocation,+      haddockForeignLibs        = packageConfigHaddockForeignLibs,       haddockExecutables        = packageConfigHaddockExecutables,       haddockTestSuites         = packageConfigHaddockTestSuites,       haddockBenchmarks         = packageConfigHaddockBenchmarks,@@ -389,7 +393,7 @@     GlobalFlags {       globalCacheDir          = projectConfigCacheDir,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = projectConfigWorldFile,+      globalWorldFile         = _,       globalHttpTransport     = projectConfigHttpTransport,       globalIgnoreExpiry      = projectConfigIgnoreExpiry     } = globalFlags@@ -402,7 +406,7 @@       installDryRun             = projectConfigDryRun,       installOnly               = _,       installOnlyDeps           = projectConfigOnlyDeps,-      installRootCmd            = projectConfigRootCmd,+      installRootCmd            = _,       installSummaryFile        = projectConfigSummaryFile,       installLogFile            = projectConfigLogFile,       installBuildReports       = projectConfigBuildReports,@@ -410,6 +414,7 @@       installSymlinkBinDir      = projectConfigSymlinkBinDir,       installOneShot            = projectConfigOneShot,       installNumJobs            = projectConfigNumJobs,+      installKeepGoing          = projectConfigKeepGoing,       installOfflineMode        = projectConfigOfflineMode     } = installFlags @@ -465,15 +470,18 @@       globalCacheDir          = projectConfigCacheDir,       globalLocalRepos        = projectConfigLocalRepos,       globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = projectConfigWorldFile,+      globalWorldFile         = mempty,       globalRequireSandbox    = mempty,       globalIgnoreSandbox     = mempty,       globalIgnoreExpiry      = projectConfigIgnoreExpiry,-      globalHttpTransport     = projectConfigHttpTransport+      globalHttpTransport     = projectConfigHttpTransport,+      globalNix               = mempty     }      configFlags = mempty {       configVerbosity     = projectConfigVerbosity,+      configDistPref      = projectConfigDistDir,+      configAllowOlder    = projectConfigAllowOlder,       configAllowNewer    = projectConfigAllowNewer     } @@ -494,21 +502,27 @@       installMaxBackjumps      = projectConfigMaxBackjumps,       installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,       installReorderGoals      = projectConfigReorderGoals,+      installCountConflicts    = projectConfigCountConflicts,       installIndependentGoals  = mempty, --projectConfigIndependentGoals,       installShadowPkgs        = mempty, --projectConfigShadowPkgs,       installStrongFlags       = projectConfigStrongFlags,+      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,       installOnly              = mempty,       installOnlyDeps          = projectConfigOnlyDeps,-      installRootCmd           = projectConfigRootCmd,+      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+      installOfflineMode       = projectConfigOfflineMode,+      installProjectFileName   = projectConfigProjectFile     }  @@ -526,6 +540,7 @@     }   where     configFlags = ConfigFlags {+      configArgs                = mempty,       configPrograms_           = mempty,       configProgramPaths        = mempty,       configProgramArgs         = mempty,@@ -533,6 +548,7 @@       configHcFlavor            = projectConfigHcFlavor,       configHcPath              = projectConfigHcPath,       configHcPkg               = projectConfigHcPkg,+      configInstantiateWith     = mempty,       configVanillaLib          = mempty,       configProfLib             = mempty,       configSharedLib           = mempty,@@ -548,6 +564,7 @@       configInstallDirs         = mempty,       configScratchDir          = mempty,       configDistPref            = mempty,+      configCabalFilePath       = mempty,       configVerbosity           = mempty,       configUserInstall         = mempty, --projectConfigUserInstall,       configPackageDBs          = mempty, --projectConfigPackageDBs,@@ -560,7 +577,9 @@       configConstraints         = mempty,       configDependencies        = mempty,       configExtraIncludeDirs    = mempty,+      configDeterministic       = mempty,       configIPID                = mempty,+      configCID                 = mempty,       configConfigurationsFlags = mempty,       configTests               = mempty,       configCoverage            = mempty, --TODO: don't merge@@ -570,6 +589,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = mempty,       configDebugInfo           = mempty,+      configAllowOlder          = mempty,       configAllowNewer          = mempty     } @@ -587,6 +607,7 @@     }   where     configFlags = ConfigFlags {+      configArgs                = mempty,       configPrograms_           = configPrograms_ mempty,       configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),       configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),@@ -594,6 +615,7 @@       configHcFlavor            = mempty,       configHcPath              = mempty,       configHcPkg               = mempty,+      configInstantiateWith     = mempty,       configVanillaLib          = packageConfigVanillaLib,       configProfLib             = packageConfigProfLib,       configSharedLib           = packageConfigSharedLib,@@ -609,6 +631,7 @@       configInstallDirs         = mempty,       configScratchDir          = mempty,       configDistPref            = mempty,+      configCabalFilePath       = mempty,       configVerbosity           = mempty,       configUserInstall         = mempty,       configPackageDBs          = mempty,@@ -622,6 +645,8 @@       configDependencies        = mempty,       configExtraIncludeDirs    = packageConfigExtraIncludeDirs,       configIPID                = mempty,+      configCID                 = mempty,+      configDeterministic       = mempty,       configConfigurationsFlags = packageConfigFlagAssignment,       configTests               = packageConfigTests,       configCoverage            = packageConfigCoverage, --TODO: don't merge@@ -631,6 +656,7 @@       configFlagError           = mempty,                --TODO: ???       configRelocatable         = packageConfigRelocatable,       configDebugInfo           = packageConfigDebugInfo,+      configAllowOlder          = mempty,       configAllowNewer          = mempty     } @@ -646,6 +672,7 @@       haddockHtml          = packageConfigHaddockHtml,       haddockHtmlLocation  = packageConfigHaddockHtmlLocation,       haddockForHackage    = mempty, --TODO: added recently+      haddockForeignLibs   = packageConfigHaddockForeignLibs,       haddockExecutables   = packageConfigHaddockExecutables,       haddockTestSuites    = packageConfigHaddockTestSuites,       haddockBenchmarks    = packageConfigHaddockBenchmarks,@@ -773,7 +800,7 @@       ]   . filterFields       [ "remote-repo-cache"-      , "logs-dir", "world-file", "ignore-expiry", "http-transport"+      , "logs-dir", "ignore-expiry", "http-transport"       ]   . commandOptionsToFields   ) (commandOptions (globalCommand []) ParseArgs)@@ -782,11 +809,18 @@       legacyConfigureShFlags       (\flags conf -> conf { legacyConfigureShFlags = flags })   . addFields+      [ simpleField "allow-older"+        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)+        (fmap unAllowOlder . configAllowOlder)+        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })+      ]+  . addFields       [ simpleField "allow-newer"-        (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer)-        configAllowNewer (\v conf -> conf { configAllowNewer = v })+        (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps)+        (fmap unAllowNewer . configAllowNewer)+        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })       ]-  . filterFields ["verbose"]+  . filterFields ["verbose", "builddir" ]   . commandOptionsToFields   ) (configureOptions ParseArgs)  ++@@ -823,26 +857,27 @@       , "root-cmd", "symlink-bindir"       , "build-log"       , "remote-build-reporting", "report-planning-failure"-      , "one-shot", "jobs", "offline"+      , "one-shot", "jobs", "keep-going", "offline", "per-component"         -- solver flags:-      , "max-backjumps", "reorder-goals", "strong-flags"+      , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"+      , "allow-boot-library-installs", "index-state"       ]   . commandOptionsToFields   ) (installOptions ParseArgs)   where     constraintSrc = ConstraintSourceProjectConfig "TODO" -parseAllowNewer :: ReadP r AllowNewer-parseAllowNewer =-     ((const AllowNewerNone <$> (Parse.string "none" +++ Parse.string "None"))-  +++ (const AllowNewerAll  <$> (Parse.string "all"  +++ Parse.string "All")))-  <++ (      AllowNewerSome <$> parseOptCommaList parse)+parseRelaxDeps :: ReadP r RelaxDeps+parseRelaxDeps =+     ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None"))+  +++ (const RelaxDepsAll  <$> (Parse.string "all"  +++ Parse.string "All")))+  <++ (      RelaxDepsSome <$> parseOptCommaList parse) -dispAllowNewer :: AllowNewer -> Doc-dispAllowNewer  AllowNewerNone       = Disp.text "None"-dispAllowNewer (AllowNewerSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma-                                                 . map disp $ pkgs-dispAllowNewer  AllowNewerAll        = Disp.text "All"+dispRelaxDeps :: RelaxDeps -> Doc+dispRelaxDeps  RelaxDepsNone       = Disp.text "None"+dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma+                                               . map disp $ pkgs+dispRelaxDeps  RelaxDepsAll        = Disp.text "All"   legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]@@ -877,13 +912,13 @@           (\v conf -> conf { configConfigurationsFlags = v })       ]   . filterFields-      [ "compiler", "with-compiler", "with-hc-pkg"+      [ "with-compiler", "with-hc-pkg"       , "program-prefix", "program-suffix"       , "library-vanilla", "library-profiling"       , "shared", "executable-dynamic"       , "profiling", "executable-profiling"       , "profiling-detail", "library-profiling-detail"-      , "optimization", "debug-info", "library-for-ghci", "split-objs"+      , "library-for-ghci", "split-objs"       , "executable-stripping", "library-stripping"       , "tests", "benchmarks"       , "coverage", "library-coverage"@@ -919,6 +954,7 @@       ("haddock-"++)   . filterFields       [ "hoogle", "html", "html-location"+      , "foreign-libraries"       , "executables", "tests", "benchmarks", "all", "internal", "css"       , "hyperlink-source", "hscolour-css"       , "contents-location", "keep-temp-files"@@ -1081,11 +1117,11 @@ programOptionsFieldDescrs :: (a -> [(String, [String])])                           -> ([(String, [String])] -> a -> a)                           -> [FieldDescr a]-programOptionsFieldDescrs get set =+programOptionsFieldDescrs get' set =     commandOptionsToFields-  $ programConfigurationOptions+  $ programDbOptions       defaultProgramDb-      ParseArgs get set+      ParseArgs get' set  programOptionsSectionDescr :: SectionDescr LegacyPackageConfig programOptionsSectionDescr =@@ -1110,7 +1146,7 @@ programLocationsFieldDescrs :: [FieldDescr ConfigFlags] programLocationsFieldDescrs =      commandOptionsToFields-   $ programConfigurationPaths'+   $ programDbPaths'        (++ "-location")        defaultProgramDb        ParseArgs@@ -1136,25 +1172,25 @@     }  --- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'.-programConfigurationOptions+programDbOptions   :: ProgramDb   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOptions progConf showOrParseArgs get set =+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 progConf)+                 (knownPrograms progDb)   where     programOptions prog =       option "" [prog ++ "-options"]         ("give extra options to " ++ prog)-        get set+        get' set         (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])            (\progArgs -> [ joinsArgs args                          | (prog', args) <- progArgs, prog==prog' ]))@@ -1213,11 +1249,11 @@ -- of parseOptCommaList below listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldWithSep separator name showF readF get set =-  liftField get set' $+listFieldWithSep separator name showF readF get' set =+  liftField get' set' $     ParseUtils.field name showF' (parseOptCommaList readF)   where-    set' xs b = set (get b ++ xs) b+    set' xs b = set (get' b ++ xs) b     showF'    = separator . map showF  --TODO: [code cleanup] local redefinition that should replace the version in
Distribution/Client/ProjectConfig/Types.hs view
@@ -8,6 +8,7 @@     ProjectConfig(..),     ProjectConfigBuildOnly(..),     ProjectConfigShared(..),+    ProjectConfigProvenance(..),     PackageConfig(..),      -- * Resolving configuration@@ -22,14 +23,21 @@ import Distribution.Client.Types          ( RemoteRepo ) import Distribution.Client.Dependency.Types-         ( PreSolver, ConstraintSource )+         ( PreSolver ) import Distribution.Client.Targets          ( UserConstraint )-import Distribution.Client.BuildReports.Types +import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) +import Distribution.Client.IndexUtils.Timestamp+         ( IndexState )++import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.ConstraintSource+ import Distribution.Package-         ( PackageName, PackageId, UnitId, Dependency )+         ( PackageName, PackageId, UnitId )+import Distribution.Types.Dependency import Distribution.Version          ( Version ) import Distribution.System@@ -40,7 +48,7 @@          ( Compiler, CompilerFlavor          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup-         ( Flag, AllowNewer(..) )+         ( Flag, AllowNewer(..), AllowOlder(..) ) import Distribution.Simple.InstallDirs          ( PathTemplate ) import Distribution.Utils.NubList@@ -50,9 +58,11 @@  import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set) import Distribution.Compat.Binary (Binary) import Distribution.Compat.Semigroup import GHC.Generics (Generic)+import Data.Typeable   -------------------------------@@ -80,14 +90,15 @@    = ProjectConfig {         -- | Packages in this project, including local dirs, local .cabal files-       -- local and remote tarballs. Where these are file globs, they must-       -- match something.+       -- 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.+       -- pick up deps that we unpack locally without erroring when+       -- there aren't any.        projectPackagesOptional      :: [String],         -- | Packages in this project from remote source repositories.@@ -96,12 +107,18 @@        -- | Packages in this project from hackage repositories.        projectPackagesNamed         :: [Dependency], +       -- See respective types for an explanation of what these+       -- values are about:        projectConfigBuildOnly       :: ProjectConfigBuildOnly,        projectConfigShared          :: ProjectConfigShared,+       projectConfigProvenance      :: Set ProjectConfigProvenance,++       -- | 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)+  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@@ -120,14 +137,13 @@        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,-       projectConfigWorldFile             :: Flag FilePath,-       projectConfigRootCmd               :: Flag String+       projectConfigLogsDir               :: Flag FilePath      }   deriving (Eq, Show, Generic) @@ -137,6 +153,8 @@ -- data ProjectConfigShared    = ProjectConfigShared {+       projectConfigDistDir           :: Flag FilePath,+       projectConfigProjectFile       :: Flag FilePath,        projectConfigHcFlavor          :: Flag CompilerFlavor,        projectConfigHcPath            :: Flag FilePath,        projectConfigHcPkg             :: Flag FilePath,@@ -153,20 +171,25 @@        -- configuration used both by the solver and other phases        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.        projectConfigLocalRepos        :: NubList FilePath,+       projectConfigIndexState        :: Flag IndexState,         -- solver configuration        projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],        projectConfigPreferences       :: [Dependency],        projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused        projectConfigSolver            :: Flag PreSolver,+       projectConfigAllowOlder        :: Maybe AllowOlder,        projectConfigAllowNewer        :: Maybe AllowNewer,        projectConfigMaxBackjumps      :: Flag Int,-       projectConfigReorderGoals      :: Flag Bool,-       projectConfigStrongFlags       :: Flag Bool+       projectConfigReorderGoals      :: Flag ReorderGoals,+       projectConfigCountConflicts    :: Flag CountConflicts,+       projectConfigStrongFlags       :: Flag StrongFlags,+       projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,+       projectConfigPerComponent      :: Flag Bool         -- More things that only make sense for manual mode, not --local mode        -- too much control!-     --projectConfigIndependentGoals  :: Flag Bool,+     --projectConfigIndependentGoals  :: Flag IndependentGoals,      --projectConfigShadowPkgs        :: Flag Bool,      --projectConfigReinstall         :: Flag Bool,      --projectConfigAvoidReinstalls   :: Flag Bool,@@ -176,6 +199,21 @@   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.@@ -215,6 +253,7 @@        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@@ -229,13 +268,14 @@ instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly instance Binary ProjectConfigShared+instance Binary ProjectConfigProvenance instance Binary 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)+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)  instance Ord k => Monoid (MapLast k v) where   mempty  = MapLast Map.empty@@ -249,7 +289,7 @@ -- | 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)+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)  instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where   mempty  = MapMappend Map.empty@@ -313,20 +353,24 @@        solverSettingFlagAssignments   :: Map PackageName FlagAssignment,        solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused        solverSettingSolver            :: PreSolver,+       solverSettingAllowOlder        :: AllowOlder,        solverSettingAllowNewer        :: AllowNewer,        solverSettingMaxBackjumps      :: Maybe Int,-       solverSettingReorderGoals      :: Bool,-       solverSettingStrongFlags       :: Bool+       solverSettingReorderGoals      :: ReorderGoals,+       solverSettingCountConflicts    :: CountConflicts,+       solverSettingStrongFlags       :: StrongFlags,+       solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,+       solverSettingIndexState        :: IndexState        -- Things that only make sense for manual mode, not --local mode        -- too much control!-     --solverSettingIndependentGoals  :: Bool,+     --solverSettingIndependentGoals  :: IndependentGoals,      --solverSettingShadowPkgs        :: Bool,      --solverSettingReinstall         :: Bool,      --solverSettingAvoidReinstalls   :: Bool,      --solverSettingOverrideReinstall :: Bool,      --solverSettingUpgradeDeps       :: Bool      }-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  instance Binary SolverSettings @@ -354,13 +398,13 @@        buildSettingSymlinkBinDir         :: [FilePath],        buildSettingOneShot               :: Bool,        buildSettingNumJobs               :: Int,+       buildSettingKeepGoing             :: Bool,        buildSettingOfflineMode           :: Bool,        buildSettingKeepTempFiles         :: Bool,        buildSettingRemoteRepos           :: [RemoteRepo],        buildSettingLocalRepos            :: [FilePath],        buildSettingCacheDir              :: FilePath,        buildSettingHttpTransport         :: Maybe String,-       buildSettingIgnoreExpiry          :: Bool,-       buildSettingRootCmd               :: Maybe String+       buildSettingIgnoreExpiry          :: Bool      }
Distribution/Client/ProjectOrchestration.hs view
@@ -1,4 +1,6 @@+{-# 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,@@ -38,152 +40,235 @@ -- 'ElaboratedInstallPlan'. -- module Distribution.Client.ProjectOrchestration (+    -- * Discovery phase: what is in the project?+    establishProjectBaseContext,+    ProjectBaseContext(..),+    BuildTimeSettings(..),+    commandLineFlagsToProjectConfig,+     -- * Pre-build phase: decide what to do.     runProjectPreBuildPhase,-    CliConfigFlags,-    PreBuildHooks(..),     ProjectBuildContext(..), +    -- ** Selecting what targets we mean+    readTargetSelectors,+    reportTargetSelectorProblems,+    resolveTargets,+    TargetsMap,+    TargetSelector(..),+    PackageId,+    AvailableTarget(..),+    AvailableTargetStatus(..),+    TargetRequested(..),+    ComponentName(..),+    ComponentKind(..),+    ComponentTarget(..),+    SubComponentTarget(..),+    TargetProblemCommon(..),+    selectComponentTargetBasic,+    distinctTargetComponents,+    -- ** Utils for selecting targets+    filterTargetsKind,+    filterTargetsKindWith,+    selectBuildableTargets,+    selectBuildableTargetsWith,+    selectBuildableTargets',+    selectBuildableTargetsWith',+    forgetTargetsDetail,+     -- ** Adjusting the plan-    selectTargets,+    pruneInstallPlanToTargets,+    TargetAction(..),+    pruneInstallPlanToDependencies,+    CannotPruneDependencies(..),     printPlan,      -- * Build phase: now do it.     runProjectBuildPhase,      -- * Post build actions-    reportBuildFailures,+    runProjectPostBuildPhase,+    dieOnBuildFailures,++    -- * Shared CLI utils+    cmdCommonHelpTextNewBuildBeta,   ) where  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.Types-                   hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)-                          , DocsResult(..), TestsResult(..) )+                   ( GenericReadyPackage(..), UnresolvedSourcePackage ) import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.BuildTarget-                   ( UserBuildTarget, resolveUserBuildTargets-                   , BuildTarget(..), buildTargetPackage )+import           Distribution.Client.TargetSelector+                   ( TargetSelector(..)+                   , ComponentKind(..), componentKind+                   , readTargetSelectors, reportTargetSelectorProblems ) import           Distribution.Client.DistDirLayout import           Distribution.Client.Config (defaultCabalDir) import           Distribution.Client.Setup hiding (packageName) +import           Distribution.Solver.Types.OptionalStanza+ import           Distribution.Package                    hiding (InstalledPackageId, installedPackageId)-import qualified Distribution.PackageDescription as PD-import           Distribution.PackageDescription (FlagAssignment)-import qualified Distribution.InstalledPackageInfo as Installed-import           Distribution.Simple.Setup (HaddockFlags)+import           Distribution.PackageDescription (FlagAssignment, showFlagValue)+import           Distribution.Simple.LocalBuildInfo+                   ( ComponentName(..), pkgComponents )+import qualified Distribution.Simple.Setup as Setup+import           Distribution.Simple.Command (commandShowOptions) -import           Distribution.Simple.Utils (die, notice)+import           Distribution.Simple.Utils+                   ( die'+                   , notice, noticeNoWrap, debugNoWrap ) import           Distribution.Verbosity import           Distribution.Text +import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map import           Data.Map (Map) import           Data.List+import           Data.Maybe import           Data.Either-import           System.Exit (exitFailure)+import           Control.Exception (Exception(..), throwIO, assert)+import           System.Exit (ExitCode(..), exitFailure)+#ifdef MIN_VERSION_unix+import           System.Posix.Signals (sigKILL, sigSEGV)+#endif  --- | Command line configuration flags. These are used to extend\/override the--- project configuration.+-- | This holds the context of a project prior to solving: the content of the+-- @cabal.project@ and all the local package @.cabal@ files. ---type CliConfigFlags = ( GlobalFlags-                      , ConfigFlags, ConfigExFlags-                      , InstallFlags, HaddockFlags )+data ProjectBaseContext = ProjectBaseContext {+       distDirLayout  :: DistDirLayout,+       cabalDirLayout :: CabalDirLayout,+       projectConfig  :: ProjectConfig,+       localPackages  :: [UnresolvedSourcePackage],+       buildSettings  :: BuildTimeSettings+     } --- | Hooks to alter the behaviour of 'runProjectPreBuildPhase'.------ For example the @configure@, @build@ and @repl@ commands use this to get--- their different behaviour.----data PreBuildHooks = PreBuildHooks {-       hookPrePlanning      :: FilePath-                            -> DistDirLayout+establishProjectBaseContext :: Verbosity                             -> ProjectConfig-                            -> IO (),-       hookSelectPlanSubset :: ElaboratedInstallPlan-                            -> IO ElaboratedInstallPlan-     }+                            -> IO ProjectBaseContext+establishProjectBaseContext verbosity cliConfig = do --- | This holds the context between the pre-build and build phases.+    cabalDir <- defaultCabalDir+    projectRoot <- either throwIO return =<<+                   findProjectRoot Nothing mprojectFile++    let cabalDirLayout = defaultCabalDirLayout cabalDir+        distDirLayout  = defaultDistDirLayout projectRoot+                                              mdistDirectory++    (projectConfig, localPackages) <-+      rebuildProjectConfig verbosity+                           distDirLayout+                           cliConfig++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings+    }+  where+    mdistDirectory = Setup.flagToMaybe projectConfigDistDir+    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile+    ProjectConfigShared {+      projectConfigDistDir,+      projectConfigProjectFile+    } = projectConfigShared cliConfig+++-- | This holds the context between the pre-build, build and post-build phases. -- data ProjectBuildContext = ProjectBuildContext {-      distDirLayout    :: DistDirLayout,-      elaboratedPlan   :: ElaboratedInstallPlan,-      elaboratedShared :: ElaboratedSharedConfig,-      pkgsBuildStatus  :: BuildStatusMap,-      buildSettings    :: BuildTimeSettings+      -- | 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     }   -- | Pre-build phase: decide what to do. ---runProjectPreBuildPhase :: Verbosity-                        -> CliConfigFlags-                        -> PreBuildHooks-                        -> IO ProjectBuildContext runProjectPreBuildPhase+    :: Verbosity+    -> ProjectBaseContext+    -> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan)+    -> IO ProjectBuildContext+runProjectPreBuildPhase     verbosity-    ( globalFlags-    , configFlags, configExFlags-    , installFlags, haddockFlags )-    PreBuildHooks{..} = do--    cabalDir <- defaultCabalDir-    let cabalDirLayout = defaultCabalDirLayout cabalDir--    projectRootDir <- findProjectRoot-    let distDirLayout = defaultDistDirLayout projectRootDir--    let cliConfig = commandLineFlagsToProjectConfig-                      globalFlags configFlags configExFlags-                      installFlags haddockFlags--    hookPrePlanning-      projectRootDir-      distDirLayout-      cliConfig+    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, projectConfig) <-+    (elaboratedPlan, _, elaboratedShared) <-       rebuildInstallPlan verbosity-                         projectRootDir distDirLayout cabalDirLayout-                         cliConfig--    let buildSettings = resolveBuildTimeSettings-                          verbosity cabalDirLayout-                          (projectConfigShared    projectConfig)-                          (projectConfigBuildOnly projectConfig)-                          (projectConfigBuildOnly cliConfig)+                         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' <- hookSelectPlanSubset elaboratedPlan+    elaboratedPlan' <- selectPlanSubset elaboratedPlan -    -- Check if any packages don't need rebuilding, and improve the plan.+    -- Check which packages need rebuilding.     -- This also gives us more accurate reasons for the --dry-run output.     ---    (elaboratedPlan'', pkgsBuildStatus) <--      rebuildTargetsDryRun distDirLayout-                           elaboratedPlan'+    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 {-      distDirLayout,-      elaboratedPlan = elaboratedPlan'',+      elaboratedPlanOriginal = elaboratedPlan,+      elaboratedPlanToExecute = elaboratedPlan'',       elaboratedShared,-      pkgsBuildStatus,-      buildSettings+      pkgsBuildStatus     }  @@ -193,16 +278,70 @@ -- rebuild the various packages needed. -- runProjectBuildPhase :: Verbosity+                     -> ProjectBaseContext                      -> ProjectBuildContext-                     -> IO ElaboratedInstallPlan-runProjectBuildPhase verbosity ProjectBuildContext {..} =+                     -> IO BuildOutcomes+runProjectBuildPhase _ ProjectBaseContext{buildSettings} _+  | buildSettingDryRun buildSettings+  = return Map.empty++runProjectBuildPhase verbosity+                     ProjectBaseContext{..} ProjectBuildContext {..} =+    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $     rebuildTargets verbosity                    distDirLayout-                   elaboratedPlan+                   (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++    writePlanGhcEnvironment distDirLayout+                            elaboratedPlanOriginal+                            elaboratedShared+                            postBuildStatus++    -- Finally if there were any build failures then report them and throw+    -- an exception to terminate the program+    dieOnBuildFailures verbosity 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.@@ -224,25 +363,62 @@ -- Taking targets into account, selecting what to build -- --- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it--- required to build the given user targets.+-- | 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). ----- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable.+-- 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. ---selectTargets :: PackageTarget-              -> (ComponentTarget -> PackageTarget)-              -> [UserBuildTarget]-              -> ElaboratedInstallPlan-              -> IO ElaboratedInstallPlan-selectTargets targetDefaultComponents targetSpecificComponent-              userBuildTargets installPlan = do--    -- Match the user targets against the available targets. If no targets are-    -- given this uses the package in the current directory, if any.-    ---    buildTargets <- resolveUserBuildTargets localPackages userBuildTargets-    --TODO: [required eventually] report something if there are no targets+type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] +-- | 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 PackageId+                          -> [AvailableTarget k]+                          -> Either err [k])+               -> (forall k. PackageId -> ComponentName -> SubComponentTarget+                          -> AvailableTarget k+                          -> Either err  k )+               -> (TargetProblemCommon -> err)+               -> ElaboratedInstallPlan+               -> [TargetSelector PackageId]+               -> Either [err] TargetsMap+resolveTargets selectPackageTargets selectComponentTarget liftProblem+               installPlan targetSelectors =     --TODO: [required eventually]     -- we cannot resolve names of packages other than those that are     -- directly in the current plan. We ought to keep a set of the known@@ -250,124 +426,192 @@     -- really need that until we can do something sensible with packages     -- outside of the project. -    -- Now check if those targets belong to the current project or not.-    -- Ultimately we want to do something sensible for targets not in this-    -- project, but for now we just bail. This gives us back the ipkgid from-    -- the plan.-    ---    buildTargets' <- either reportBuildTargetProblems return-                   $ resolveAndCheckTargets-                       targetDefaultComponents-                       targetSpecificComponent-                       installPlan-                       buildTargets--    -- Finally, prune the install plan to cover just those target packages-    -- and their deps.-    ---    return (pruneInstallPlanToTargets buildTargets' installPlan)-  where-    localPackages =-      [ (pkgDescription pkg, pkgSourceLocation pkg)-      | InstallPlan.Configured pkg <- InstallPlan.toList installPlan ]-      --TODO: [code cleanup] is there a better way to identify local packages?--+    case partitionEithers+           [ fmap ((,) targetSelector) (checkTarget targetSelector)+           | targetSelector <- targetSelectors ] of+      ([], targets) -> Right+                     . Map.map nubComponentTargets+                     $ Map.fromListWith (++)+                         [ (uid, [(ct, ts)])+                         | (ts, cts) <- targets+                         , (uid, ct) <- cts ] -resolveAndCheckTargets :: PackageTarget-                       -> (ComponentTarget -> PackageTarget)-                       -> ElaboratedInstallPlan-                       -> [BuildTarget PackageName]-                       -> Either [BuildTargetProblem]-                                 (Map InstalledPackageId [PackageTarget])-resolveAndCheckTargets targetDefaultComponents-                       targetSpecificComponent-                       installPlan targets =-    case partitionEithers (map checkTarget targets) of-      ([], targets') -> Right $ Map.fromListWith (++)-                                  [ (ipkgid, [t]) | (ipkgid, t) <- targets' ]-      (problems, _)  -> Left problems+      (problems, _) -> Left problems   where     -- TODO [required eventually] currently all build targets refer to packages     -- inside the project. Ultimately this has to be generalised to allow     -- referring to other packages and targets.+    checkTarget :: TargetSelector PackageId+                -> Either err [(UnitId, ComponentTarget)]      -- We can ask to build any whole package, project-local or a dependency-    checkTarget (BuildTargetPackage pn)-      | Just ipkgid <- Map.lookup pn projAllPkgs-      = Right (ipkgid, targetDefaultComponents)--    -- But if we ask to build an individual component, then that component-    -- had better be in a package that is local to the project.-    -- TODO: and if it's an optional stanza, then that stanza must be available-    checkTarget t@(BuildTargetComponent pn cn)-      | Just ipkgid <- Map.lookup pn projLocalPkgs-      = Right (ipkgid, targetSpecificComponent-                         (ComponentTarget cn WholeComponent))--      | Map.member pn projAllPkgs-      = Left (BuildTargetComponentNotProjectLocal t)+    checkTarget bt@(TargetPackage _ pkgid mkfilter)+      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)+                  $ Map.lookup pkgid availableTargetsByPackage+      = case selectPackageTargets bt ats of+          Left  e  -> Left e+          Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent)+                            | (unitid, cname) <- ts ] -    checkTarget t@(BuildTargetModule pn cn mn)-      | Just ipkgid <- Map.lookup pn projLocalPkgs-      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn)))+      | otherwise+      = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) -      | Map.member pn projAllPkgs-      = Left (BuildTargetComponentNotProjectLocal t)+    checkTarget bt@(TargetAllPackages mkfilter) =+      let ats = maybe id filterTargetsKind mkfilter+              $ filter availableTargetLocalToProject+              $ concat (Map.elems availableTargetsByPackage)+       in case selectPackageTargets bt ats of+            Left  e  -> Left e+            Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent)+                              | (unitid, cname) <- ts ] -    checkTarget t@(BuildTargetFile pn cn fn)-      | Just ipkgid <- Map.lookup pn projLocalPkgs-      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn)))+    checkTarget (TargetComponent pkgid cname subtarget)+      | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent+      = case partitionEithers+               (map (selectComponentTarget pkgid cname subtarget) ats) of+          (e:_,_) -> Left e+          ([],ts) -> Right [ (unitid, ctarget)+                           | let ctarget = ComponentTarget cname subtarget+                           , (unitid, _) <- ts ] -      | Map.member pn projAllPkgs-      = Left (BuildTargetComponentNotProjectLocal t)+      | Map.member pkgid availableTargetsByPackage+      = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) -    checkTarget t-      = Left (BuildTargetNotInProject (buildTargetPackage t))+      | otherwise+      = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) +    --TODO: check if the package is in the plan, even if it's not local+    --TODO: check if the package is in hackage and return different+    -- error cases here so the commands can handle things appropriately -    projAllPkgs, projLocalPkgs :: Map PackageName InstalledPackageId-    projAllPkgs =-      Map.fromList-        [ (packageName pkg, installedPackageId pkg)-        | pkg <- InstallPlan.toList installPlan ]+    availableTargetsByPackage   :: Map PackageId                  [AvailableTarget (UnitId, ComponentName)]+    availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)]+    availableTargetsByComponent = availableTargets installPlan+    availableTargetsByPackage   = Map.mapKeysWith+                                    (++) (\(pkgid, _cname) -> pkgid)+                                    availableTargetsByComponent+                      `Map.union` availableTargetsEmptyPackages -    projLocalPkgs =+    -- 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-        [ (packageName pkg, installedPackageId pkg)+        [ (packageId pkg, [])         | InstallPlan.Configured pkg <- InstallPlan.toList installPlan-        , case pkgSourceLocation pkg of-            LocalUnpackedPackage _ -> True; _ -> False-          --TODO: [code cleanup] is there a better way to identify local packages?+        , 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) -data BuildTargetProblem-   = BuildTargetNotInProject PackageName-   | BuildTargetComponentNotProjectLocal (BuildTarget PackageName)-   | BuildTargetOptionalStanzaDisabled Bool-      -- ^ @True@: explicitly disabled by user-      -- @False@: disabled by solver+filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]+filterTargetsKind ckind = filterTargetsKindWith (== ckind) -reportBuildTargetProblems :: [BuildTargetProblem] -> IO a-reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem+filterTargetsKindWith :: (ComponentKind -> Bool)+                     -> [AvailableTarget k] -> [AvailableTarget k]+filterTargetsKindWith p ts =+    [ t | t@(AvailableTarget _ cname _ _) <- ts+        , p (componentKind cname) ] -reportBuildTargetProblem :: BuildTargetProblem -> String-reportBuildTargetProblem (BuildTargetNotInProject pn) =-        "Cannot build the package " ++ display pn ++ ", 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."+selectBuildableTargets :: [AvailableTarget k] -> [k]+selectBuildableTargets ts =+    [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] -reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) =-        "The package " ++ display (buildTargetPackage t) ++ " is in the "-     ++ "project but it is not a locally unpacked package, so  "+selectBuildableTargetsWith :: (TargetRequested -> Bool)+                          -> [AvailableTarget k] -> [k]+selectBuildableTargetsWith p ts =+    [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] -reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined+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 :: PackageId+                           -> ComponentName+                           -> SubComponentTarget+                           -> AvailableTarget k+                           -> Either TargetProblemCommon k+selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} =+    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++data TargetProblemCommon+   = TargetNotInProject                   PackageName+   | TargetComponentNotProjectLocal       PackageId ComponentName SubComponentTarget+   | TargetComponentNotBuildable          PackageId ComponentName SubComponentTarget+   | TargetOptionalStanzaDisabledByUser   PackageId ComponentName SubComponentTarget+   | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget++    -- 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+  deriving (Eq, Show)++-- | 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 --@@ -375,46 +619,70 @@ -- | Print a user-oriented presentation of the install plan, indicating what -- will be built. ---printPlan :: Verbosity -> ProjectBuildContext -> IO ()+printPlan :: Verbosity+          -> ProjectBaseContext+          -> ProjectBuildContext+          -> IO () printPlan verbosity-          ProjectBuildContext {-            elaboratedPlan,-            pkgsBuildStatus,+          ProjectBaseContext {             buildSettings = BuildTimeSettings{buildSettingDryRun}           }+          ProjectBuildContext {+            elaboratedPlanToExecute = elaboratedPlan,+            elaboratedShared,+            pkgsBuildStatus+          }    | null pkgs   = notice verbosity "Up to date" -  | verbosity >= verbose-  = notice verbosity $ unlines $-      ("In order, the following " ++ wouldWill ++ " be built:")+  | otherwise+  = noticeNoWrap verbosity $ unlines $+      ("In order, the following " ++ wouldWill ++ " be built" +++      ifNormal " (use -v for more details)" ++ ":")     : map showPkgAndReason pkgs -  | otherwise-  = notice verbosity $ unlines $-      ("In order, the following " ++ wouldWill-       ++ " be built (use -v for more details):")-    : map showPkg pkgs   where-    pkgs = linearizeInstallPlan elaboratedPlan+    pkgs = InstallPlan.executionOrder elaboratedPlan +    ifVerbose s | verbosity >= verbose = s+                | otherwise            = ""++    ifNormal s | verbosity >= verbose = ""+               | otherwise            = s+     wouldWill | buildSettingDryRun = "would"               | otherwise          = "will" -    showPkg pkg = display (packageId pkg)-     showPkgAndReason :: ElaboratedReadyPackage -> String-    showPkgAndReason (ReadyPackage pkg _) =-      display (packageId pkg) ++-      showTargets pkg ++-      showFlagAssignment (nonDefaultFlags pkg) ++-      showStanzas pkg ++-      let buildStatus = pkgsBuildStatus Map.! installedPackageId pkg in+    showPkgAndReason (ReadyPackage elab) =+      " - " +++      (if verbosity >= deafening+        then display (installedUnitId elab)+        else display (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" display (compComponentName comp) +++        if Map.null (elabInstantiatedWith elab)+            then ""+            else " with " +++                intercalate ", "+                    -- TODO: Abbreviate the UnitIds+                    [ display k ++ "=" ++ display v+                    | (k,v) <- Map.toList (elabInstantiatedWith elab) ]+     nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment-    nonDefaultFlags pkg = pkgFlagAssignment pkg \\ pkgFlagDefaults pkg+    nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab      showStanzas pkg = concat                     $ [ " *test"@@ -422,21 +690,53 @@                    ++ [ " *bench"                       | BenchStanzas `Set.member` pkgStanzasEnabled pkg ] -    showTargets pkg-      | null (pkgBuildTargets pkg) = ""+    showTargets elab+      | null (elabBuildTargets elab) = ""       | otherwise-      = " (" ++ unwords [ showComponentTarget pkg t | t <- pkgBuildTargets pkg ]+      = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ]              ++ ")" -    -- TODO: [code cleanup] this should be a proper function in a proper place     showFlagAssignment :: FlagAssignment -> String     showFlagAssignment = concatMap ((' ' :) . showFlagValue)-    showFlagValue (f, True)   = '+' : showFlagName f-    showFlagValue (f, False)  = '-' : showFlagName f-    showFlagName (PD.FlagName f) = f +    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+            -- TODO: Closely logic from 'configureProfiling'.+            tryExeProfiling = Setup.fromFlagOrDefault False+                                (configProf fullConfigureFlags)+            tryLibProfiling = Setup.fromFlagOrDefault False+                                (Mon.mappend (configProf    fullConfigureFlags)+                                             (configProfExe fullConfigureFlags))+            partialConfigureFlags+              = Mon.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 -> "already installed"+      BuildStatusPreExisting -> "existing package"+      BuildStatusInstalled   -> "already installed"       BuildStatusDownload {} -> "requires download & build"       BuildStatusUnpack   {} -> "requires build"       BuildStatusRebuild _ rebuild -> case rebuild of@@ -446,48 +746,237 @@         BuildStatusBuild _ buildreason -> case buildreason of           BuildReasonDepsRebuilt      -> "dependency rebuilt"           BuildReasonFilesChanged-            (MonitoredFileChanged _)  -> "files changed"-          BuildReasonFilesChanged             mreason                   -> showMonitorChangedReason mreason           BuildReasonExtraTargets _   -> "additional components to build"           BuildReasonEphemeralTargets -> "ephemeral targets"       BuildStatusUpToDate {} -> "up to date" -- doesn't happen -    showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file+    showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file ++ " changed"     showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"     showMonitorChangedReason  MonitorFirstRun     = "first run"     showMonitorChangedReason  MonitorCorruptCache = "cannot read state cache" -linearizeInstallPlan :: ElaboratedInstallPlan -> [ElaboratedReadyPackage]-linearizeInstallPlan =-    unfoldr next++-- | If there are build failures then report them and throw an exception.+--+dieOnBuildFailures :: Verbosity+                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()+dieOnBuildFailures verbosity 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+       die' 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-    next plan = case InstallPlan.ready plan of-      []      -> Nothing-      (pkg:_) -> Just (pkg, plan')+    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)+      ]++    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 (ie 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)+      = 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+          InstallFailed   _ -> "Failed to build "  ++ pkgstr+          DependentFailed depid+                            -> "Failed to build " ++ display (packageId pkg)+                            ++ " because it depends on " ++ display depid+                            ++ " which itself failed to build"+      where+        pkgstr = elabConfiguredName verbosity pkg+              ++ if mentionDepOf+                   then renderDependencyOf (installedUnitId pkg)+                   else ""++    renderFailureExtraDetail reason =+      case reason of+        ConfigureFailed _ -> " The failure occurred during the configure step."+        InstallFailed   _ -> " The failure occurred during the final install step."+        _                 -> ""++    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-          ipkgid = installedPackageId pkg-          ipkg   = Installed.emptyInstalledPackageInfo {-                     Installed.sourcePackageId    = packageId pkg,-                     Installed.installedUnitId = ipkgid-                   }-          plan'  = InstallPlan.completed ipkgid (Just ipkg)-                     (BuildOk DocsNotTried TestsNotTried)-                     (InstallPlan.processing [pkg] plan)-    --TODO: [code cleanup] This is a bit of a hack, pretending that each package is installed-    -- could we use InstallPlan.topologicalOrder?+          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 -reportBuildFailures :: ElaboratedInstallPlan -> IO ()-reportBuildFailures plan =+    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+        InstallFailed   e -> Just e+        DependentFailed _ -> Nothing -  case [ (pkg, reason)-       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of-    []      -> return ()-    _failed -> exitFailure-    --TODO: [required eventually] see the old printBuildFailures for an example-    -- of the kind of things we could report, but we want to handle the special-    -- case of the current package better, since if you do "cabal build" then-    -- you don't need a lot of context to explain where the ghc error message-    -- comes from, and indeed extra noise would just be annoying.+data BuildFailurePresentation =+       ShowBuildSummaryOnly   BuildFailureReason+     | ShowBuildSummaryAndLog BuildFailureReason FilePath+++cmdCommonHelpTextNewBuildBeta :: String+cmdCommonHelpTextNewBuildBeta =+    "Note: this command is part of the new project-based system (aka "+ ++ "nix-style\nlocal builds). These features are currently in beta. "+ ++ "Please see\n"+ ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "+ ++ "for\ndetails and advice on what you can expect to work. If you "+ ++ "encounter problems\nplease file issues at "+ ++ "https://github.com/haskell/cabal/issues and if you\nhave any time "+ ++ "to get involved and help with testing, fixing bugs etc then\nthat "+ ++ "is very much appreciated.\n"
Distribution/Client/ProjectPlanOutput.hs view
@@ -2,31 +2,65 @@              DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,              ScopedTypeVariables #-} --- | An experimental new UI for cabal for working with multiple packages------------------------------------------------------------------------------ module Distribution.Client.ProjectPlanOutput (+    -- * Plan output     writePlanExternalRepresentation,++    -- * Project status+    -- | Several outputs rely on having a general overview of+    PostBuildProjectStatus(..),+    updatePostBuildProjectStatus,+    writePlanGhcEnvironment,   ) where  import           Distribution.Client.ProjectPlanning.Types-                   ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..)-                   , ElaboratedSharedConfig(..) )+import           Distribution.Client.ProjectBuilding.Types import           Distribution.Client.DistDirLayout+import           Distribution.Client.Types (confInstId)+import           Distribution.Client.PackageHash (showHashValue)  import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J-import qualified Distribution.Client.ComponentDeps as ComponentDeps+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))+import           Distribution.Simple.Compiler+                   ( PackageDBStack, PackageDB(..)+                   , compilerVersion, compilerFlavor, showCompilerId )+import           Distribution.Simple.GHC+                   ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)+                   , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile+                   , writeGhcEnvironmentFile ) import           Distribution.Text+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 qualified Paths_cabal_install as Our (version) +import           Data.Maybe (maybeToList, fromMaybe) import           Data.Monoid+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB +import           System.FilePath+import           System.IO ++-----------------------------------------------------------------------------+-- 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.@@ -40,61 +74,736 @@     writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $         BB.toLazyByteString       . J.encodeToBuilder-      $ encodePlanAsJson elaboratedInstallPlan elaboratedSharedConfig+      $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig  -- | Renders a subset of the elaborated install plan in a semi-stable JSON -- format. ---encodePlanAsJson :: ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value-encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig =+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 Our.version              , "cabal-lib-version" J..= jdisplay cabalVersion-             , "install-plan"      J..= jsonIPlan+             , "compiler-id"       J..= (J.String . showCompilerId . pkgConfigCompiler)+                                        elaboratedSharedConfig+             , "os"                J..= jdisplay os+             , "arch"              J..= jdisplay arch+             , "install-plan"      J..= installPlanToJ elaboratedInstallPlan              ]   where-    jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan)+    Platform arch os = pkgConfigPlatform elaboratedSharedConfig -    -- ipi :: InstalledPackageInfo-    toJ (InstallPlan.PreExisting ipi) =-      -- installed packages currently lack configuration information-      -- such as their flag settings or non-lib components.+    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.       ---      -- TODO: how to find out whether package is "local"?       J.object         [ "type"       J..= J.String "pre-existing"-        , "id"         J..= jdisplay (installedUnitId ipi)-        , "components" J..= J.object-          [ "lib" J..= J.object [ "depends" J..= map jdisplay (installedDepends ipi) ] ]+        , "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)         ] -    -- ecp :: ElaboratedConfiguredPackage-    toJ (InstallPlan.Configured ecp) =-      J.object-        [ "type"       J..= J.String "configured"-        , "id"         J..= (jdisplay . installedUnitId) ecp-        , "components" J..= components-        , "flags"      J..= J.object [ fn J..= v-                                     | (PD.FlagName fn,v) <- pkgFlagAssignment ecp ]-        ]-      where-        components = J.object-          [ comp2str c J..= J.object-            [ "depends" J..= map (jdisplay . installedUnitId) v ]-          | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ]+    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) <- elabFlagAssignment elab ]+        , "style"      J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle 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+      dist_dir = distBuildDirectory distDirLayout+                    (elabDistDirParams elaboratedSharedConfig elab) -    toJ _ = error "encodePlanToJson: only expecting PreExisting and Configured"+      bin_file c = case c of+        ComponentDeps.ComponentExe s   -> bin_file' s+        ComponentDeps.ComponentTest s  -> bin_file' s+        ComponentDeps.ComponentBench s -> bin_file' s+        _ -> []+      bin_file' s =+        ["bin-file" J..= J.String bin]+       where+        bin = if elabBuildStyle elab == BuildInplaceOnly+               then dist_dir </> "build" </> display s </> display s+               else InstallDirs.bindir (elabInstallDirs elab) </> display s      -- TODO: maybe move this helper to "ComponentDeps" module?     --       Or maybe define a 'Text' instance?+    comp2str :: ComponentDeps.Component -> String     comp2str c = case c of         ComponentDeps.ComponentLib     -> "lib"-        ComponentDeps.ComponentExe s   -> "exe:"   <> s-        ComponentDeps.ComponentTest s  -> "test:"  <> s-        ComponentDeps.ComponentBench s -> "bench:" <> s+        ComponentDeps.ComponentSubLib s -> "lib:"   <> display s+        ComponentDeps.ComponentFLib s  -> "flib:"  <> display s+        ComponentDeps.ComponentExe s   -> "exe:"   <> display s+        ComponentDeps.ComponentTest s  -> "test:"  <> display s+        ComponentDeps.ComponentBench s -> "bench:" <> display s         ComponentDeps.ComponentSetup   -> "setup" +    style2str :: Bool -> BuildStyle -> String+    style2str True  _                = "local"+    style2str False BuildInplaceOnly = "inplace"+    style2str False BuildAndInstall  = "global"+     jdisplay :: Text a => a -> J.Value     jdisplay = J.String . display+++-----------------------------------------------------------------------------+-- 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 display . 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++-- Writing .ghc.environment files+--++writePlanGhcEnvironment :: DistDirLayout+                        -> ElaboratedInstallPlan+                        -> ElaboratedSharedConfig+                        -> PostBuildProjectStatus+                        -> IO ()+writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory}+                        elaboratedInstallPlan+                        ElaboratedSharedConfig {+                          pkgConfigCompiler = compiler,+                          pkgConfigPlatform = platform+                        }+                        postBuildStatus+  | compilerFlavor compiler == GHC+  , supportsPkgEnvFiles (getImplInfo compiler)+  --TODO: check ghcjs compat+  --TODO: This feature is temporarily disabled due to #4010+  , False+  = writeGhcEnvironmentFile+      distProjectRootDirectory+      platform (compilerVersion compiler)+      (renderGhcEnviromentFile distProjectRootDirectory+                               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 ()++renderGhcEnviromentFile :: FilePath+                        -> ElaboratedInstallPlan+                        -> PostBuildProjectStatus+                        -> [GhcEnvironmentFileEntry]+renderGhcEnviromentFile 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    = selectGhcEnviromentFileLibraries postBuildStatus+    packageDBs = relativePackageDBPaths projectRootDir $+                 selectGhcEnviromentFilePackageDbs elaboratedInstallPlan+++-- 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.+--+selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId]+selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} =+    case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of+      Nothing    -> error "renderGhcEnviromentFile: 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+++selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack+selectGhcEnviromentFilePackageDbs 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 $ "renderGhcEnviromentFile: 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 view
@@ -1,2283 +1,3356 @@ {-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}---- | Planning how to build everything in a project.----module Distribution.Client.ProjectPlanning (-    -- * elaborated install plan types-    ElaboratedInstallPlan,-    ElaboratedConfiguredPackage(..),-    ElaboratedPlanPackage,-    ElaboratedSharedConfig(..),-    ElaboratedReadyPackage,-    BuildStyle(..),-    CabalFileText,--    --TODO: [code cleanup] these types should live with execution, not with-    --      plan definition. Need to better separate InstallPlan definition.-    GenericBuildResult(..),-    BuildResult,-    BuildSuccess(..),-    BuildFailure(..),-    DocsResult(..),-    TestsResult(..),--    -- * Producing the elaborated install plan-    rebuildInstallPlan,--    -- * Build targets-    PackageTarget(..),-    ComponentTarget(..),-    SubComponentTarget(..),-    showComponentTarget,--    -- * Selecting a plan subset-    pruneInstallPlanToTargets,--    -- * Utils required for building-    pkgHasEphemeralBuildTargets,-    pkgBuildTargetWholeComponents,--    -- * Setup.hs CLI flags for building-    setupHsScriptOptions,-    setupHsConfigureFlags,-    setupHsBuildFlags,-    setupHsBuildArgs,-    setupHsReplFlags,-    setupHsReplArgs,-    setupHsCopyFlags,-    setupHsRegisterFlags,-    setupHsHaddockFlags,--    packageHashInputs,--    -- TODO: [code cleanup] utils that should live in some shared place?-    createPackageDBIfMissing-  ) where--import           Distribution.Client.ProjectPlanning.Types-import           Distribution.Client.PackageHash-import           Distribution.Client.RebuildMonad-import           Distribution.Client.ProjectConfig-import           Distribution.Client.ProjectPlanOutput--import           Distribution.Client.Types-                   hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)-                          , DocsResult(..), TestsResult(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.Dependency-import           Distribution.Client.Dependency.Types-import qualified Distribution.Client.ComponentDeps as CD-import           Distribution.Client.ComponentDeps (ComponentDeps)-import qualified Distribution.Client.IndexUtils as IndexUtils-import qualified Distribution.Client.PackageIndex as SourcePackageIndex-import           Distribution.Client.Targets (userToPackageConstraint)-import           Distribution.Client.DistDirLayout-import           Distribution.Client.SetupWrapper-import           Distribution.Client.JobControl-import           Distribution.Client.FetchUtils-import qualified Hackage.Security.Client as Sec-import           Distribution.Client.PkgConfigDb-import           Distribution.Client.Setup hiding (packageName, cabalVersion)-import           Distribution.Utils.NubList--import           Distribution.Package hiding-  (InstalledPackageId, installedPackageId)-import           Distribution.System-import qualified Distribution.PackageDescription as Cabal-import qualified Distribution.PackageDescription as PD-import qualified Distribution.PackageDescription.Configuration as PD-import qualified Distribution.InstalledPackageInfo as Installed-import           Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import           Distribution.Simple.Compiler hiding (Flag)-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 (ComponentName(..))-import qualified Distribution.Simple.Register as Cabal-import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Simple.BuildTarget as Cabal--import           Distribution.Simple.Utils hiding (matchFileGlob)-import           Distribution.Version-import           Distribution.Verbosity-import           Distribution.Text--import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Graph as Graph-import qualified Data.Tree  as Tree-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif-import           Control.Monad-import           Control.Monad.State as State-import           Control.Exception-import           Data.List-import           Data.Maybe-import           Data.Either-import           Data.Monoid-import           Data.Function-import           System.FilePath-import           System.Directory (doesDirectoryExist)------------------------------------------------------------------------------------ * 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 =---sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig-                                       -> ElaboratedConfiguredPackage-                                       -> Bool-sanityCheckElaboratedConfiguredPackage sharedConfig-                                       pkg@ElaboratedConfiguredPackage{..} =--    pkgStanzasEnabled `Set.isSubsetOf` pkgStanzasAvailable--    -- the stanzas explicitly enabled should be available and enabled- && Map.keysSet (Map.filter id pkgStanzasRequested)-      `Set.isSubsetOf` pkgStanzasEnabled--    -- the stanzas explicitly disabled should not be available- && Set.null (Map.keysSet (Map.filter not pkgStanzasRequested)-                `Set.intersection` pkgStanzasAvailable)-- && (pkgBuildStyle == BuildInplaceOnly ||-     installedPackageId pkg == hashedInstalledPackageId-                                 (packageHashInputs sharedConfig pkg))-- && (pkgBuildStyle == BuildInplaceOnly ||-     Set.null pkgStanzasAvailable)------------------------------------------------------------------------------------ * Deciding what to do: making an 'ElaboratedInstallPlan'---------------------------------------------------------------------------------rebuildInstallPlan :: Verbosity-                   -> FilePath -> DistDirLayout -> CabalDirLayout-                   -> ProjectConfig-                   -> IO ( ElaboratedInstallPlan-                         , ElaboratedSharedConfig-                         , ProjectConfig )-rebuildInstallPlan verbosity-                   projectRootDir-                   distDirLayout@DistDirLayout {-                     distDirectory,-                     distProjectCacheFile,-                     distProjectCacheDirectory-                   }-                   cabalDirLayout@CabalDirLayout {-                     cabalPackageCacheDirectory,-                     cabalStoreDirectory,-                     cabalStorePackageDB-                   }-                   cliConfig =-    runRebuild projectRootDir $ do-    progsearchpath <- liftIO $ getSystemSearchPath-    let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }--    -- The overall improved plan is cached-    rerunIfChanged verbosity fileMonitorImprovedPlan-                   -- react to changes in command line args and the path-                   (cliConfigPersistent, progsearchpath) $ do--      -- And so is the elaborated plan that the improved plan based on-      (elaboratedPlan, elaboratedShared,-       projectConfig) <--        rerunIfChanged verbosity fileMonitorElaboratedPlan-                       (cliConfigPersistent, progsearchpath) $ do--          (projectConfig, projectConfigTransient) <- phaseReadProjectConfig-          localPackages <- phaseReadLocalPackages projectConfig-          compilerEtc   <- phaseConfigureCompiler projectConfig-          _             <- phaseConfigurePrograms projectConfig compilerEtc-          solverPlan    <- phaseRunSolver         projectConfigTransient-                                                  compilerEtc localPackages-          (elaboratedPlan,-           elaboratedShared) <- phaseElaboratePlan projectConfigTransient-                                                   compilerEtc-                                                   solverPlan localPackages-          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared--          return (elaboratedPlan, elaboratedShared,-                  projectConfig)--      -- 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, elaboratedShared, projectConfig)--  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--    -- Read the cabal.project (or implicit config) and combine it with-    -- arguments from the command line-    ---    phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig)-    phaseReadProjectConfig = do-      liftIO $ do-        info verbosity "Project settings changed, reconfiguring..."-        createDirectoryIfMissingVerbose verbosity False distDirectory-        createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory--      projectConfig <- readProjectConfig verbosity projectRootDir--      -- The project config comming from the command line includes "build only"-      -- flags that we don't cache persistently (because like all "build only"-      -- flags they do not affect the value of the outcome) but that we do-      -- sometimes using during planning (in particular the http transport)-      let projectConfigTransient  = projectConfig <> cliConfig-          projectConfigPersistent = projectConfig-                                 <> cliConfig {-                                      projectConfigBuildOnly = mempty-                                    }-      liftIO $ writeProjectConfigFile (distProjectCacheFile "config")-                                      projectConfigPersistent-      return (projectConfigPersistent, projectConfigTransient)--    -- Look for all the cabal packages in the project-    -- some of which may be local src dirs, tarballs etc-    ---    phaseReadLocalPackages :: ProjectConfig-                           -> Rebuild [SourcePackage]-    phaseReadLocalPackages projectConfig = do--      localCabalFiles <- findProjectPackages projectRootDir projectConfig-      mapM (readSourcePackage verbosity) localCabalFiles---    -- 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)-                   -> [SourcePackage]-                   -> Rebuild (SolverInstallPlan, PackagesImplicitSetupDeps)-    phaseRunSolver projectConfig@ProjectConfig {-                     projectConfigShared,-                     projectConfigBuildOnly-                   }-                   (compiler, platform, progdb)-                   localPackages =-        rerunIfChanged verbosity fileMonitorSolverPlan-                       (solverSettings, cabalPackageCacheDirectory,-                        localPackages, localPackagesEnabledStanzas,-                        compiler, platform, programsDbSignature progdb) $ do--          installedPkgIndex <- getInstalledPackages verbosity-                                                    compiler progdb platform-                                                    corePackageDbs-          sourcePkgDb       <- getSourcePackages    verbosity withRepoCtx-          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..."-            foldProgress logMsg die return $-              planPackages compiler platform solver solverSettings-                           installedPkgIndex sourcePkgDb pkgConfigDB-                           localPackages localPackagesEnabledStanzas-      where-        corePackageDbs = [GlobalPackageDB]-        withRepoCtx    = projectConfigWithSolverRepoContext verbosity-                           cabalPackageCacheDirectory-                           projectConfigShared-                           projectConfigBuildOnly-        solverSettings = resolveSolverSettings projectConfig-        logMsg message rest = debugNoWrap verbosity message >> rest--        localPackagesEnabledStanzas =-          Map.fromList-            [ (pkgname, stanzas)-            | pkg <- localPackages-            , let pkgname            = packageName pkg-                  testsEnabled       = lookupLocalPackageConfig-                                         packageConfigTests-                                         projectConfig pkgname-                  benchmarksEnabled  = lookupLocalPackageConfig-                                         packageConfigBenchmarks-                                         projectConfig pkgname-                  stanzas =-                    Map.fromList $-                      [ (TestStanzas, enabled)-                      | enabled <- flagToList testsEnabled ]-                   ++ [ (BenchStanzas , enabled)-                      | enabled <- flagToList benchmarksEnabled ]-            ]--    -- 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)-                       -> (SolverInstallPlan, PackagesImplicitSetupDeps)-                       -> [SourcePackage]-                       -> Rebuild ( ElaboratedInstallPlan-                                  , ElaboratedSharedConfig )-    phaseElaboratePlan ProjectConfig {-                         projectConfigShared,-                         projectConfigLocalPackages,-                         projectConfigSpecificPackage,-                         projectConfigBuildOnly-                       }-                       (compiler, platform, progdb)-                       (solverPlan, pkgsImplicitSetupDeps)-                       localPackages = do--        liftIO $ debug verbosity "Elaborating the install plan..."--        sourcePackageHashes <--          rerunIfChanged verbosity fileMonitorSourceHashes-                         (packageLocationsSignature solverPlan) $-            getPackageSourceHashes verbosity withRepoCtx solverPlan--        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler-        return $-          elaborateInstallPlan-            platform compiler progdb-            distDirLayout-            cabalDirLayout-            solverPlan-            pkgsImplicitSetupDeps-            localPackages-            sourcePackageHashes-            defaultInstallDirs-            projectConfigShared-            projectConfigLocalPackages-            (getMapMappend projectConfigSpecificPackage)-      where-        withRepoCtx = projectConfigWithSolverRepoContext verbosity-                        cabalPackageCacheDirectory-                        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.-    ---    -- TODO: [required eventually] maintain the ghc environment file reflecting-    -- the libs available. This will need to be after plan improvement phase.-    ---    phaseMaintainPlanOutputs :: ElaboratedInstallPlan-                             -> ElaboratedSharedConfig-                             -> Rebuild ()-    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = do-        liftIO $ debug verbosity "Updating plan.json"-        liftIO $ 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..."-        recreateDirectory verbosity True storeDirectory-        storePkgIndex <- getPackageDBContents verbosity-                                              compiler progdb platform-                                              storePackageDb-        let improvedPlan = improveInstallPlanWithPreExistingPackages-                             storePkgIndex-                             elaboratedPlan-        return improvedPlan--      where-        storeDirectory  = cabalStoreDirectory (compilerId compiler)-        storePackageDb  = cabalStorePackageDB (compilerId compiler)-        ElaboratedSharedConfig {-          pkgConfigPlatform      = platform,-          pkgConfigCompiler      = compiler,-          pkgConfigCompilerProgs = progdb-        } = 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.----programsDbSignature :: ProgramDb -> [ConfiguredProgram]-programsDbSignature 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--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)-                  -> Rebuild SourcePackageDb-getSourcePackages verbosity withRepoCtx = do-    (sourcePkgDb, repos) <--      liftIO $-        withRepoCtx $ \repoctx -> do-          sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx-          return (sourcePkgDb, repoContextRepos repoctx)--    monitorFiles . map monitorFile-                 . IndexUtils.getSourcePackagesMonitorFiles-                 $ repos-    return sourcePkgDb--createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb-                         -> PackageDBStack -> IO ()-createPackageDBIfMissing verbosity compiler progdb packageDbs =-  case reverse packageDbs of-    SpecificPackageDB dbPath : _ -> do-      exists <- liftIO $ Cabal.doesPackageDBExist dbPath-      unless exists $ do-        createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath)-        Cabal.createPackageDB verbosity compiler progdb False dbPath-    _ -> return ()---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.-    forM_ dirs $ \dir -> do-        dirExists <- liftIO $ doesDirectoryExist dir-        -- TODO: turn this into a utility function-        monitorFiles [if dirExists-                        then monitorDirectory dir-                        else monitorNonExistentDirectory dir]--    liftIO $ readPkgConfigDb verbosity progdb---recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()-recreateDirectory verbosity createParents dir = do-    liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir-    monitorFiles [monitorDirectoryExistence dir]----- | Select the config values to monitor for changes package source hashes.-packageLocationsSignature :: SolverInstallPlan-                          -> [(PackageId, PackageLocation (Maybe FilePath))]-packageLocationsSignature solverPlan =-    [ (packageId pkg, packageSource pkg)-    | InstallPlan.Configured-        (ConfiguredPackage pkg _ _ _) <- InstallPlan.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, packageSource pkg)-          | InstallPlan.Configured-              (ConfiguredPackage pkg _ _ _) <- InstallPlan.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)-        --TODO: [required eventually] finish remote tarball functionality---        allRemoteTarballPkgs =---          [ (pkgid, )---          | (pkgid, RemoteTarballPackage ) <- 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 grp))-              . 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-                          ++ 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 :: Compiler-             -> Platform-             -> Solver -> SolverSettings-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [SourcePackage]-             -> Map PackageName (Map OptionalStanza Bool)-             -> Progress String String-                         (SolverInstallPlan, PackagesImplicitSetupDeps)-planPackages comp platform solver SolverSettings{..}-             installedPkgIndex sourcePkgDb pkgConfigDB-             localPackages pkgStanzasEnable =--    rememberImplicitSetupDeps (depResolverSourcePkgIndex stdResolverParams) <$>--    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--        --TODO: [required eventually] should only be configurable for custom installs-   -- . setIndependentGoals solverSettingIndependentGoals--      . setReorderGoals solverSettingReorderGoals--        --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--        --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)-}--      . removeUpperBounds solverSettingAllowNewer--      . addDefaultSetupDependencies (defaultSetupDeps comp platform-                                   . PD.packageDescription-                                   . packageDescription)--      . addPreferences-          -- preferences from the config file or command line-          [ PackageVersionPreference name ver-          | Dependency 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 = packageName 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-              (PackageConstraintStanzas pkgname stanzas)-              ConstraintSourceConfigFlagOrTarget-          | pkg <- localPackages-          , let pkgname = packageName 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-              (PackageConstraintFlags pkgname 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-              (PackageConstraintFlags pkgname flags)-              ConstraintSourceConfigFlagOrTarget-          | let flags = solverSettingFlagAssignment-          , not (null flags)-          , pkg <- localPackages-          , let pkgname = packageName pkg ]--      $ stdResolverParams--    stdResolverParams =-      standardInstallPolicy-        installedPkgIndex sourcePkgDb-        (map SpecificSourcePackage localPackages)------------------------------------------------------------------------------------ * 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----------------------------------------------------------------------------------- | 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-  :: Platform -> Compiler -> ProgramDb-  -> DistDirLayout-  -> CabalDirLayout-  -> SolverInstallPlan-  -> PackagesImplicitSetupDeps-  -> [SourcePackage]-  -> Map PackageId PackageSourceHash-  -> InstallDirs.InstallDirTemplates-  -> ProjectConfigShared-  -> PackageConfig-  -> Map PackageName PackageConfig-  -> (ElaboratedInstallPlan, ElaboratedSharedConfig)-elaborateInstallPlan platform compiler compilerprogdb-                     DistDirLayout{..}-                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}-                     solverPlan pkgsImplicitSetupDeps localPackages-                     sourcePackageHashes-                     defaultInstallDirs-                     _sharedPackageConfig-                     localPackagesConfig-                     perPackageConfig =-    (elaboratedInstallPlan, elaboratedSharedConfig)-  where-    elaboratedSharedConfig =-      ElaboratedSharedConfig {-        pkgConfigPlatform      = platform,-        pkgConfigCompiler      = compiler,-        pkgConfigCompilerProgs = compilerprogdb-      }--    elaboratedInstallPlan =-      flip InstallPlan.mapPreservingGraph solverPlan $ \mapDep planpkg ->-        case planpkg of-          InstallPlan.PreExisting pkg ->-            InstallPlan.PreExisting pkg--          InstallPlan.Configured  pkg ->-            InstallPlan.Configured-              (elaborateConfiguredPackage (fixupDependencies mapDep pkg))--          _ -> error "elaborateInstallPlan: unexpected package state"--    -- remap the installed package ids of the direct deps, since we're-    -- changing the installed package ids of all the packages to use the-    -- final nix-style hashed ids.-    fixupDependencies mapDep-       (ConfiguredPackage pkg flags stanzas deps) =-        ConfiguredPackage pkg flags stanzas deps'-      where-        deps' = fmap (map (\d -> d { confInstId = mapDep (confInstId d) })) deps--    elaborateConfiguredPackage :: ConfiguredPackage-                               -> ElaboratedConfiguredPackage-    elaborateConfiguredPackage-        pkg@(ConfiguredPackage (SourcePackage pkgid gdesc srcloc descOverride)-                               flags stanzas deps) =-        elaboratedPackage-      where-        -- Knot tying: the final elaboratedPackage includes the-        -- pkgInstalledId, which is calculated by hashing many-        -- of the other fields of the elaboratedPackage.-        ---        elaboratedPackage = ElaboratedConfiguredPackage {..}--        pkgInstalledId-          | shouldBuildInplaceOnly pkg-          = mkUnitId (display pkgid ++ "-inplace")--          | otherwise-          = assert (isJust pkgSourceHash) $-            hashedInstalledPackageId-              (packageHashInputs-                elaboratedSharedConfig-                elaboratedPackage)  -- recursive use of elaboratedPackage--          | otherwise-          = error $ "elaborateInstallPlan: non-inplace package "-                 ++ " is missing a source hash: " ++ display pkgid--        -- All the other fields of the ElaboratedConfiguredPackage-        ---        pkgSourceId         = pkgid-        pkgDescription      = let Right (desc, _) =-                                    PD.finalizePackageDescription-                                    flags (const True)-                                    platform (compilerInfo compiler)-                                    [] gdesc-                               in desc-        pkgFlagAssignment   = flags-        pkgFlagDefaults     = [ (Cabal.flagName flag, Cabal.flagDefault flag)-                              | flag <- PD.genPackageFlags gdesc ]-        pkgDependencies     = deps-        pkgStanzasAvailable = Set.fromList stanzas-        pkgStanzasRequested =-            Map.fromList $ [ (TestStanzas,  v) | v <- maybeToList tests ]-                        ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks ]-          where-            tests, benchmarks :: Maybe Bool-            tests      = perPkgOptionMaybe pkgid packageConfigTests-            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks--        -- These sometimes get adjusted later-        pkgStanzasEnabled   = Set.empty-        pkgBuildTargets     = []-        pkgReplTarget       = Nothing-        pkgBuildHaddocks    = False--        pkgSourceLocation   = srcloc-        pkgSourceHash       = Map.lookup pkgid sourcePackageHashes-        pkgBuildStyle       = if shouldBuildInplaceOnly pkg-                                then BuildInplaceOnly else BuildAndInstall-        pkgBuildPackageDBStack    = buildAndRegisterDbs-        pkgRegisterPackageDBStack = buildAndRegisterDbs-        pkgRequiresRegistration   = isJust (Cabal.condLibrary gdesc)--        pkgSetupScriptStyle       = packageSetupScriptStylePostSolver-                                      pkgsImplicitSetupDeps pkg pkgDescription-        pkgSetupScriptCliVersion  = packageSetupScriptSpecVersion-                                      pkgSetupScriptStyle pkgDescription deps-        pkgSetupPackageDBStack    = buildAndRegisterDbs--        buildAndRegisterDbs-          | shouldBuildInplaceOnly pkg = inplacePackageDbs-          | otherwise                  = storePackageDbs--        pkgDescriptionOverride    = descOverride--        pkgVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively-        pkgSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary-        pkgDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe-        pkgGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still--        pkgProfExe       = perPkgOptionFlag pkgid False packageConfigProf-        pkgProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary--        (pkgProfExeDetail,-         pkgProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault-                               packageConfigProfDetail-                               packageConfigProfLibDetail-        pkgCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage--        pkgOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization-        pkgSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs-        pkgStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs-        pkgStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes-        pkgDebugInfo     = 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.-        pkgProgramPaths  = Map.fromList-                             [ (programId prog, programPath prog)-                             | prog <- configuredPrograms compilerprogdb ]-                        <> perPkgOptionMapLast pkgid packageConfigProgramPaths-        pkgProgramArgs   = Map.fromList-                             [ (programId prog, args)-                             | prog <- configuredPrograms compilerprogdb-                             , let args = programOverrideArgs prog-                             , not (null args)-                             ]-                        <> perPkgOptionMapMappend pkgid packageConfigProgramArgs-        pkgProgramPathExtra    = perPkgOptionNubList pkgid packageConfigProgramPathExtra-        pkgConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs-        pkgExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs-        pkgExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs-        pkgExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs-        pkgProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix-        pkgProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix--        pkgInstallDirs-          | shouldBuildInplaceOnly pkg-          -- use the ordinary default install dirs-          = (InstallDirs.absoluteInstallDirs-               pkgid-               (installedUnitId pkg)-               (compilerInfo compiler)-               InstallDirs.NoCopyDest-               platform-               defaultInstallDirs) {--              InstallDirs.libsubdir  = "", -- absoluteInstallDirs sets these as-              InstallDirs.datasubdir = ""  -- 'undefined' but we have to use-            }                              -- them as "Setup.hs configure" args--          | otherwise-          -- use special simplified install dirs-          = storePackageInstallDirs-              cabalDirLayout-              (compilerId compiler)-              pkgInstalledId--        pkgHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle-        pkgHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml-        pkgHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation-        pkgHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables-        pkgHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites-        pkgHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks-        pkgHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal-        pkgHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss-        pkgHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour-        pkgHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss-        pkgHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents--    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-      -- the project config specifies values that apply to packages local to-      -- but by default non-local packages get all default config values-      -- the project, and can specify per-package values for any package,-      | isLocalToProject pkg = local <> perpkg-      | otherwise            =          perpkg-      where-        local  = f localPackagesConfig-        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)--    inplacePackageDbs = storePackageDbs-                     ++ [ distPackageDB (compilerId compiler) ]--    storePackageDbs   = [ GlobalPackageDB-                        , cabalStorePackageDB (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 :: HasUnitId pkg => pkg -> Bool-    shouldBuildInplaceOnly pkg = Set.member (installedPackageId pkg)-                                            pkgsToBuildInplaceOnly--    pkgsToBuildInplaceOnly :: Set InstalledPackageId-    pkgsToBuildInplaceOnly =-        Set.fromList-      $ map installedPackageId-      $ InstallPlan.reverseDependencyClosure-          solverPlan-          [ fakeUnitId (packageId pkg)-          | pkg <- localPackages ]--    isLocalToProject :: Package pkg => pkg -> Bool-    isLocalToProject pkg = Set.member (packageId pkg)-                                      pkgsLocalToProject--    pkgsLocalToProject :: Set PackageId-    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]--    pkgsUseSharedLibrary :: Set PackageId-    pkgsUseSharedLibrary =-        packagesWithDownwardClosedProperty 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 =-        packagesWithDownwardClosedProperty 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--    packagesWithDownwardClosedProperty property =-        Set.fromList-      $ map packageId-      $ InstallPlan.dependencyClosure-          solverPlan-          [ installedPackageId pkg-          | pkg <- InstallPlan.toList solverPlan-          , property pkg ] -- just the packages that satisfy the propety-      --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--------------------------------- Build targets------- Refer to ProjectPlanning.Types for details of these important types:---- data PackageTarget = ...--- data ComponentTarget = ...--- data SubComponentTarget = ...-----TODO: this needs to report some user target/config errors-elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]-                        -> ([ComponentTarget], Maybe ComponentTarget, Bool)-elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =-    let buildTargets  = nubComponentTargets-                      . map compatSubComponentTargets-                      . concatMap elaborateBuildTarget-                      $ targets-        --TODO: instead of listToMaybe we should be reporting an error here-        replTargets   = listToMaybe-                      . nubComponentTargets-                      . map compatSubComponentTargets-                      . concatMap elaborateReplTarget-                      $ targets-        buildHaddocks = HaddockDefaultComponents `elem` targets--     in (buildTargets, replTargets, buildHaddocks)-  where-    --TODO: need to report an error here if defaultComponents is empty-    elaborateBuildTarget  BuildDefaultComponents    = pkgDefaultComponents-    elaborateBuildTarget (BuildSpecificComponent t) = [t]-    elaborateBuildTarget  _                         = []--    --TODO: need to report an error here if defaultComponents is empty-    elaborateReplTarget  ReplDefaultComponent     = take 1 pkgDefaultComponents-    elaborateReplTarget (ReplSpecificComponent t) = [t]-    elaborateReplTarget  _                        = []--    pkgDefaultComponents =-        [ ComponentTarget cname WholeComponent-        | c <- Cabal.pkgComponents pkgDescription-        , PD.buildable (Cabal.componentBuildInfo c)-        , let cname = Cabal.componentName c-        , enabledOptionalStanza cname-        ]-      where-        enabledOptionalStanza cname =-          case componentOptionalStanza cname of-            Nothing     -> True-            Just stanza -> Map.lookup stanza pkgStanzasRequested-                        == Just True--    -- Not all Cabal Setup.hs versions support sub-component targets, so switch-    -- them over to the whole component-    compatSubComponentTargets :: ComponentTarget -> ComponentTarget-    compatSubComponentTargets target@(ComponentTarget cname _subtarget)-      | not setupHsSupportsSubComponentTargets-                  = ComponentTarget cname WholeComponent-      | 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] []--    nubComponentTargets :: [ComponentTarget] -> [ComponentTarget]-    nubComponentTargets =-        concatMap (wholeComponentOverrides . map snd)-      . groupBy ((==)    `on` fst)-      . sortBy  (compare `on` fst)-      . map (\t@(ComponentTarget cname _) -> (cname, t))--    -- 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] -> [ComponentTarget]-    wholeComponentOverrides ts =-      case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of-        (t:_) -> [t]-        []    -> ts---pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool-pkgHasEphemeralBuildTargets pkg =-    isJust (pkgReplTarget pkg)- || (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg-                      , 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).----pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage-                              -> Set ComponentName-pkgBuildTargetWholeComponents pkg =-    Set.fromList-      [ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ]------------------------------------------------------------------------------------ * Install plan pruning----------------------------------------------------------------------------------- | Given a set of package targets (and optionally component targets within--- those packages), 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.----pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget]-                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan-pruneInstallPlanToTargets perPkgTargetsMap =-    either (\_ -> assert False undefined) id-  . InstallPlan.new False-  . PackageIndex.fromList-    -- We have to do this in two passes-  . pruneInstallPlanPass2-  . pruneInstallPlanPass1 perPkgTargetsMap-  . InstallPlan.toList---- The first pass does three things:------ * Set the build targets based on the user targets (but not rev deps yet).--- * 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 :: Map InstalledPackageId [PackageTarget]-                      -> [ElaboratedPlanPackage]-                      -> [ElaboratedPlanPackage]-pruneInstallPlanPass1 perPkgTargetsMap pkgs =-    map fst $-    dependencyClosure-      (installedPackageId . fst)  -- the pkg id-      snd                         -- the pruned deps-      [ (pkg', pruneOptionalDependencies pkg')-      | pkg <- pkgs-      , let pkg' = mapConfiguredPackage-                     (pruneOptionalStanzas . setBuildTargets) pkg-      ]-      (Map.keys perPkgTargetsMap)-  where-    -- Elaborate and set the targets we'll build for this package. This is just-    -- based on the targets from the user, not targets implied by reverse-    -- depencencies. Those comes in the second pass once we know the rev deps.-    ---    setBuildTargets pkg =-        pkg {-          pkgBuildTargets   = buildTargets,-          pkgReplTarget     = replTarget,-          pkgBuildHaddocks  = buildHaddocks-        }-      where-        (buildTargets, replTarget, buildHaddocks)-                = elaboratePackageTargets pkg targets-        targets = fromMaybe []-                $ Map.lookup (installedPackageId pkg) perPkgTargetsMap--    -- Decide whether or not to enable testsuites and benchmarks-    ---    -- 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 depencencies 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.-    ---    pruneOptionalStanzas pkg = pkg { pkgStanzasEnabled = stanzas }-      where-        stanzas :: Set OptionalStanza-        stanzas = optionalStanzasRequiredByTargets  pkg-               <> optionalStanzasRequestedByDefault pkg-               <> optionalStanzasWithDepsAvailable availablePkgs pkg--    -- Calculate package depencencies 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 :: ElaboratedPlanPackage -> [InstalledPackageId]-    pruneOptionalDependencies (InstallPlan.Configured pkg) =-        (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg)-      where-        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-        keepNeeded _                     _ = True-        stanzas = pkgStanzasEnabled pkg-    pruneOptionalDependencies pkg =-        CD.flatDeps (depends pkg)--    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage-                                     -> Set OptionalStanza-    optionalStanzasRequiredByTargets pkg =-      Set.fromList-        [ stanza-        | ComponentTarget cname _ <- pkgBuildTargets pkg-                                  ++ maybeToList (pkgReplTarget pkg)-        , stanza <- maybeToList (componentOptionalStanza cname)-        ]--    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage-                                      -> Set OptionalStanza-    optionalStanzasRequestedByDefault =-        Map.keysSet-      . Map.filter (id :: Bool -> Bool)-      . pkgStanzasRequested--    availablePkgs =-      Set.fromList-        [ installedPackageId pkg-        | InstallPlan.PreExisting pkg <- pkgs ]--optionalStanzasWithDepsAvailable :: Set InstalledPackageId-                                 -> ElaboratedConfiguredPackage-                                 -> Set OptionalStanza-optionalStanzasWithDepsAvailable availablePkgs pkg =-    Set.fromList-      [ stanza-      | stanza <- Set.toList (pkgStanzasAvailable pkg)-      , let deps :: [InstalledPackageId]-            deps = map installedPackageId-                 $ CD.select (optionalStanzaDeps stanza)-                             (pkgDependencies 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 depencencies based on the final choice of optional stanzas.--- * Extend the targets within each package to build, now we know the reverse---   depencencies, 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 instaled /in the store/. That's important--- but it does not account for depencencies 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 pkg =-        pkg {-          pkgStanzasEnabled = stanzas,-          pkgDependencies   = CD.filterDeps keepNeeded (pkgDependencies pkg),-          pkgBuildTargets   = pkgBuildTargets pkg ++ targetsRequiredForRevDeps-        }-      where-        stanzas :: Set OptionalStanza-        stanzas = pkgStanzasEnabled pkg-               <> optionalStanzasWithDepsAvailable availablePkgs pkg--        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-        keepNeeded _                     _ = True--        targetsRequiredForRevDeps =-          [ ComponentTarget CLibName WholeComponent-          -- if anything needs this pkg, build the library component-          | installedPackageId pkg `Set.member` hasReverseLibDeps-          ]-        --TODO: also need to track build-tool rev-deps for exes--    availablePkgs :: Set InstalledPackageId-    availablePkgs = Set.fromList (map installedPackageId pkgs)--    hasReverseLibDeps :: Set InstalledPackageId-    hasReverseLibDeps =-      Set.fromList [ depid | pkg <- pkgs-                           , depid <- CD.flatDeps (depends pkg) ]---mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage)-                     -> ElaboratedPlanPackage-                     -> ElaboratedPlanPackage-mapConfiguredPackage f (InstallPlan.Configured pkg) =-  InstallPlan.Configured (f pkg)-mapConfiguredPackage _ pkg = pkg--componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza-componentOptionalStanza (Cabal.CTestName  _) = Just TestStanzas-componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas-componentOptionalStanza _                    = Nothing---dependencyClosure :: (pkg -> InstalledPackageId)-                  -> (pkg -> [InstalledPackageId])-                  -> [pkg]-                  -> [InstalledPackageId]-                  -> [pkg]-dependencyClosure pkgid deps allpkgs =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs graph-  . map pkgidToVertex-  where-    (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs--dependencyGraph :: (pkg -> InstalledPackageId)-                -> (pkg -> [InstalledPackageId])-                -> [pkg]-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    InstalledPackageId -> Graph.Vertex)-dependencyGraph pkgid deps pkgs =-    (graph, vertexToPkg', pkgidToVertex')-  where-    (graph, vertexToPkg, pkgidToVertex) =-      Graph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg )-                           | pkg <- pkgs ]-    vertexToPkg'   = (\(pkg,_,_) -> pkg)-                   . vertexToPkg-    pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure")-                   . pkgidToVertex--------------------------------- 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. 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 = ...  -- see ProjectPlanning.Types---- | Work out the 'SetupScriptStyle' given the package description.------ This only works on original packages before we give them to the solver,--- since after the solver some implicit setup deps are made explicit.------ See 'rememberImplicitSetupDeps' and 'packageSetupScriptStylePostSolver'.----packageSetupScriptStylePreSolver :: PD.PackageDescription -> SetupScriptStyle-packageSetupScriptStylePreSolver pkg-  | buildType == PD.Custom-  , isJust (PD.setupBuildInfo pkg)-  = SetupCustomExplicitDeps--  | buildType == PD.Custom-  = SetupCustomImplicitDeps--  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against-  = SetupNonCustomExternalLib--  | otherwise-  = SetupNonCustomInternalLib-  where-    buildType = fromMaybe PD.Custom (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'.----defaultSetupDeps :: Compiler -> Platform-                 -> PD.PackageDescription-                 -> Maybe [Dependency]-defaultSetupDeps compiler platform pkg =-    case packageSetupScriptStylePreSolver 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-        | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++-        [ Dependency cabalPkgname cabalConstraint-        | 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.18 < 2-          ---          cabalConstraint   = orLaterVersion cabalCompatMinVer-                                `intersectVersionRanges`-                              orLaterVersion (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 = Version [1,25] []-          -- In principle we can talk to any old Cabal version, and we need to-          -- be able to do that for custom Setup scripts that require older-          -- Cabal lib versions. However in practice we have currently have-          -- problems with Cabal-1.16. (1.16 does not know about build targets)-          -- If this is fixed we can relax this constraint.-          cabalCompatMinVer = Version [1,18] []--      -- 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-             , Dependency basePkgname  anyVersion ]-        where-          cabalConstraint = orLaterVersion (PD.specVersion pkg)--      -- The internal setup wrapper method has no deps at all.-      SetupNonCustomInternalLib -> Just []--      SetupCustomExplicitDeps ->-        error $ "defaultSetupDeps: called for a package with explicit "-             ++ "setup deps: " ++ display (packageId pkg)----- | See 'rememberImplicitSetupDeps' for details.-type PackagesImplicitSetupDeps = Set InstalledPackageId---- | A consequence of using 'defaultSetupDeps' in 'planPackages' is that by--- making implicit setup deps explicit we loose track of which packages--- originally had implicit setup deps. That's important because we do still--- have different behaviour based on the setup style (in particular whether to--- compile a Setup.hs script with version macros).------ So we remember the necessary information in an auxilliary set and use it--- in 'packageSetupScriptStylePreSolver' to recover the full info.----rememberImplicitSetupDeps :: SourcePackageIndex.PackageIndex SourcePackage-                          -> SolverInstallPlan-                          -> (SolverInstallPlan, PackagesImplicitSetupDeps)-rememberImplicitSetupDeps sourcePkgIndex plan =-    (plan, pkgsImplicitSetupDeps)-  where-    pkgsImplicitSetupDeps =-      Set.fromList-        [ installedPackageId pkg-        | InstallPlan.Configured-            pkg@(ConfiguredPackage newpkg _ _ _) <- InstallPlan.toList plan-          -- has explicit setup deps now-        , hasExplicitSetupDeps newpkg-          -- but originally had no setup deps-        , let Just origpkg = SourcePackageIndex.lookupPackageId-                               sourcePkgIndex (packageId pkg)-        , not (hasExplicitSetupDeps origpkg)-        ]--    hasExplicitSetupDeps =-        (SetupCustomExplicitDeps==)-      . packageSetupScriptStylePreSolver-      . PD.packageDescription . packageDescription----- | Use the extra info saved by 'rememberImplicitSetupDeps' to let us work--- out the correct 'SetupScriptStyle'. This should give the same result as--- 'packageSetupScriptStylePreSolver' gave prior to munging the package info--- through the solver.----packageSetupScriptStylePostSolver :: Set InstalledPackageId-                                  -> ConfiguredPackage-                                  -> PD.PackageDescription-                                  -> SetupScriptStyle-packageSetupScriptStylePostSolver pkgsImplicitSetupDeps pkg pkgDescription =-    case packageSetupScriptStylePreSolver pkgDescription of-      SetupCustomExplicitDeps-        | Set.member (installedPackageId pkg) pkgsImplicitSetupDeps-            -> SetupCustomImplicitDeps-      other -> other----- | Work out which version of the Cabal spec 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 :: Package pkg-                              => SetupScriptStyle-                              -> PD.PackageDescription-                              -> ComponentDeps [pkg]-                              -> 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 deps =-    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of-      Just dep -> packageVersion dep-      Nothing  -> PD.specVersion pkg---cabalPkgname, basePkgname :: PackageName-cabalPkgname = PackageName "Cabal"-basePkgname  = PackageName "base"---legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName]-legacyCustomSetupPkgs compiler (Platform _ os) =-    map PackageName $-        [ "array", "base", "binary", "bytestring", "containers"-        , "deepseq", "directory", "filepath", "old-time", "pretty"-        , "process", "time", "transformers" ]-     ++ [ "Win32" | os == Windows ]-     ++ [ "unix"  | os /= Windows ]-     ++ [ "ghc-prim"         | isGHC ]-     ++ [ "template-haskell" | isGHC ]-  where-    isGHC = compilerCompatFlavor GHC compiler--    -- This util is copied here just in this branch to avoid requiring a new-    -- Cabal version. The master branch already does the right thing.-    compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool-    compilerCompatFlavor flavor comp =-        flavor == compilerFlavor comp-     || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ]---- 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-                     -> ElaboratedSharedConfig-                     -> FilePath-                     -> FilePath-                     -> Bool-                     -> Lock-                     -> SetupScriptOptions-setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..} deps)-                     ElaboratedSharedConfig{..} srcdir builddir-                     isParallelBuild cacheLock =-    SetupScriptOptions {-      useCabalVersion          = thisVersion pkgSetupScriptCliVersion,-      useCabalSpecVersion      = Just pkgSetupScriptCliVersion,-      useCompiler              = Just pkgConfigCompiler,-      usePlatform              = Just pkgConfigPlatform,-      usePackageDB             = pkgSetupPackageDBStack,-      usePackageIndex          = Nothing,-      useDependencies          = [ (installedPackageId ipkg, packageId ipkg)-                                 | ipkg <- CD.setupDeps deps ],-      useDependenciesExclusive = True,-      useVersionMacros         = pkgSetupScriptStyle == SetupCustomExplicitDeps,-      useProgramConfig         = pkgConfigCompilerProgs,-      useDistPref              = builddir,-      useLoggingHandle         = Nothing, -- this gets set later-      useWorkingDir            = Just srcdir,-      useWin32CleanHack        = False,   --TODO: [required eventually]-      forceExternalSetupMethod = isParallelBuild,-      setupCacheLock           = Just cacheLock-    }----- | 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 :: CabalDirLayout-                        -> CompilerId-                        -> InstalledPackageId-                        -> InstallDirs.InstallDirs FilePath-storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory}-                        compid ipkgid =-    InstallDirs.InstallDirs {..}-  where-    prefix       = cabalStorePackageDirectory compid ipkgid-    bindir       = prefix </> "bin"-    libdir       = prefix </> "lib"-    libsubdir    = ""-    dynlibdir    = libdir-    libexecdir   = prefix </> "libexec"-    includedir   = libdir </> "include"-    datadir      = prefix </> "share"-    datasubdir   = ""-    docdir       = datadir </> "doc"-    mandir       = datadir </> "man"-    htmldir      = docdir  </> "html"-    haddockdir   = htmldir-    sysconfdir   = prefix </> "etc"-----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-                         pkg@ElaboratedConfiguredPackage{..}-                         pkgdeps)-                      sharedConfig@ElaboratedSharedConfig{..}-                      verbosity builddir =-    assert (sanityCheckElaboratedConfiguredPackage sharedConfig pkg)-    Cabal.ConfigFlags {..}-  where-    configDistPref            = toFlag builddir-    configVerbosity           = toFlag verbosity--    configIPID                = toFlag (display (installedUnitId pkg))--    configProgramPaths        = Map.toList pkgProgramPaths-    configProgramArgs         = Map.toList pkgProgramArgs-    configProgramPathExtra    = toNubList pkgProgramPathExtra-    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)-    configHcPath              = mempty -- we use configProgramPaths instead-    configHcPkg               = mempty -- we use configProgramPaths instead--    configVanillaLib          = toFlag pkgVanillaLib-    configSharedLib           = toFlag pkgSharedLib-    configDynExe              = toFlag pkgDynExe-    configGHCiLib             = toFlag pkgGHCiLib-    configProfExe             = mempty-    configProfLib             = toFlag pkgProfLib-    configProf                = toFlag pkgProfExe--    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail-    -- so we specify both so we can specify independently-    configProfDetail          = toFlag pkgProfExeDetail-    configProfLibDetail       = toFlag pkgProfLibDetail--    configCoverage            = toFlag pkgCoverage-    configLibCoverage         = mempty--    configOptimization        = toFlag pkgOptimization-    configSplitObjs           = toFlag pkgSplitObjs-    configStripExes           = toFlag pkgStripExes-    configStripLibs           = toFlag pkgStripLibs-    configDebugInfo           = toFlag pkgDebugInfo-    configAllowNewer          = mempty -- we use configExactConfiguration True--    configConfigurationsFlags = pkgFlagAssignment-    configConfigureArgs       = pkgConfigureScriptArgs-    configExtraLibDirs        = pkgExtraLibDirs-    configExtraFrameworkDirs  = pkgExtraFrameworkDirs-    configExtraIncludeDirs    = pkgExtraIncludeDirs-    configProgPrefix          = maybe mempty toFlag pkgProgPrefix-    configProgSuffix          = maybe mempty toFlag pkgProgSuffix--    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)-                                     pkgInstallDirs--    -- we only use configDependencies, unless we're talking to an old Cabal-    -- in which case we use configConstraints-    configDependencies        = [ (packageName (Installed.sourcePackageId deppkg),-                                  Installed.installedUnitId deppkg)-                                | deppkg <- CD.nonSetupDeps pkgdeps ]-    configConstraints         = [ thisPackageVersion (packageId deppkg)-                                | deppkg <- CD.nonSetupDeps pkgdeps ]--    -- explicitly clear, then our package db stack-    -- TODO: [required eventually] have to do this differently for older Cabal versions-    configPackageDBs          = Nothing : map Just pkgBuildPackageDBStack--    configTests               = toFlag (TestStanzas  `Set.member` pkgStanzasEnabled)-    configBenchmarks          = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled)--    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---setupHsBuildFlags :: ElaboratedConfiguredPackage-                  -> ElaboratedSharedConfig-                  -> Verbosity-                  -> FilePath-                  -> Cabal.BuildFlags-setupHsBuildFlags ElaboratedConfiguredPackage{..} _ 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-    }---setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]-setupHsBuildArgs pkg =-    map (showComponentTarget pkg) (pkgBuildTargets pkg)---showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String-showComponentTarget pkg =-    showBuildTarget . toBuildTarget-  where-    showBuildTarget t =-      Cabal.showBuildTarget (qlBuildTarget t) (packageId pkg) t--    qlBuildTarget Cabal.BuildTargetComponent{} = Cabal.QL2-    qlBuildTarget _                            = Cabal.QL3--    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---setupHsReplFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.ReplFlags-setupHsReplFlags ElaboratedConfiguredPackage{..} _ 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-    }---setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]-setupHsReplArgs pkg =-    maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg)-    --TODO: should be able to give multiple modules in one component---setupHsCopyFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.CopyFlags-setupHsCopyFlags _ _ verbosity builddir =-    Cabal.CopyFlags {-      --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right-      -- thing, but perhaps we ought really to copy into an image dir and do-      -- some sanity checks and move into the final location ourselves-      copyDest      = toFlag InstallDirs.NoCopyDest,-      copyDistPref  = toFlag builddir,-      copyVerbosity = toFlag verbosity-    }--setupHsRegisterFlags :: ElaboratedConfiguredPackage-                     -> ElaboratedSharedConfig-                     -> Verbosity-                     -> FilePath-                     -> FilePath-                     -> Cabal.RegisterFlags-setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _-                     verbosity builddir pkgConfFile =-    Cabal.RegisterFlags {-      regPackageDB   = mempty,  -- misfeature-      regGenScript   = mempty,  -- never use-      regGenPkgConf  = toFlag (Just pkgConfFile),-      regInPlace     = case pkgBuildStyle of-                         BuildInplaceOnly -> toFlag True-                         _                -> toFlag False,-      regPrintId     = mempty,  -- never use-      regDistPref    = toFlag builddir,-      regVerbosity   = toFlag verbosity-    }--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 pkgHaddockHoogle,-      haddockHtml          = toFlag pkgHaddockHtml,-      haddockHtmlLocation  = maybe mempty toFlag pkgHaddockHtmlLocation,-      haddockForHackage    = mempty, --TODO: new flag-      haddockExecutables   = toFlag pkgHaddockExecutables,-      haddockTestSuites    = toFlag pkgHaddockTestSuites,-      haddockBenchmarks    = toFlag pkgHaddockBenchmarks,-      haddockInternal      = toFlag pkgHaddockInternal,-      haddockCss           = maybe mempty toFlag pkgHaddockCss,-      haddockHscolour      = toFlag pkgHaddockHscolour,-      haddockHscolourCss   = maybe mempty toFlag pkgHaddockHscolourCss,-      haddockContents      = maybe mempty toFlag pkgHaddockContents,-      haddockDistPref      = toFlag builddir,-      haddockKeepTempFiles = mempty, --TODO: from build settings-      haddockVerbosity     = toFlag verbosity-    }--{--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-    pkg@ElaboratedConfiguredPackage{-      pkgSourceId,-      pkgSourceHash = Just srchash,-      pkgDependencies-    } =-    PackageHashInputs {-      pkgHashPkgId       = pkgSourceId,-      pkgHashSourceHash  = srchash,-      pkgHashDirectDeps  = Set.fromList-                             [ installedPackageId dep-                             | dep <- CD.select relevantDeps pkgDependencies ],-      pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg-    }-  where-    -- Obviously the main deps are relevant-    relevantDeps  CD.ComponentLib      = 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. "-         ++ display (packageId pkg)--packageHashConfigInputs :: ElaboratedSharedConfig-                        -> ElaboratedConfiguredPackage-                        -> PackageHashConfigInputs-packageHashConfigInputs-    ElaboratedSharedConfig{..}-    ElaboratedConfiguredPackage{..} =--    PackageHashConfigInputs {-      pkgHashCompilerId          = compilerId pkgConfigCompiler,-      pkgHashPlatform            = pkgConfigPlatform,-      pkgHashFlagAssignment      = pkgFlagAssignment,-      pkgHashConfigureScriptArgs = pkgConfigureScriptArgs,-      pkgHashVanillaLib          = pkgVanillaLib,-      pkgHashSharedLib           = pkgSharedLib,-      pkgHashDynExe              = pkgDynExe,-      pkgHashGHCiLib             = pkgGHCiLib,-      pkgHashProfLib             = pkgProfLib,-      pkgHashProfExe             = pkgProfExe,-      pkgHashProfLibDetail       = pkgProfLibDetail,-      pkgHashProfExeDetail       = pkgProfExeDetail,-      pkgHashCoverage            = pkgCoverage,-      pkgHashOptimization        = pkgOptimization,-      pkgHashSplitObjs           = pkgSplitObjs,-      pkgHashStripLibs           = pkgStripLibs,-      pkgHashStripExes           = pkgStripExes,-      pkgHashDebugInfo           = pkgDebugInfo,-      pkgHashExtraLibDirs        = pkgExtraLibDirs,-      pkgHashExtraFrameworkDirs  = pkgExtraFrameworkDirs,-      pkgHashExtraIncludeDirs    = pkgExtraIncludeDirs,-      pkgHashProgPrefix          = pkgProgPrefix,-      pkgHashProgSuffix          = pkgProgSuffix-    }----- | Given the 'InstalledPackageIndex' for a nix-style package store, and an--- 'ElaboratedInstallPlan', replace configured source packages by pre-existing--- installed packages whenever they exist.----improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex-                                          -> ElaboratedInstallPlan-                                          -> ElaboratedInstallPlan-improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan =-    replaceWithPreExisting installPlan-      [ ipkg-      | InstallPlan.Configured pkg-          <- InstallPlan.reverseTopologicalOrder installPlan-      , ipkg <- maybeToList (canPackageBeImproved pkg) ]-  where-    --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.--    canPackageBeImproved pkg =-      PackageIndex.lookupUnitId-        installedPkgIndex (installedPackageId pkg)--    replaceWithPreExisting =-      foldl' (\plan ipkg -> InstallPlan.preexisting-                              (installedPackageId ipkg) ipkg plan)+{-# 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,+    setupHsCopyFlags,+    setupHsRegisterFlags,+    setupHsHaddockFlags,++    packageHashInputs,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++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.Targets (userToPackageConstraint)+import           Distribution.Client.DistDirLayout+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+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.ModuleName+import           Distribution.Package hiding+  (InstalledPackageId, installedPackageId)+import           Distribution.Types.AnnotatedId+import           Distribution.Types.ComponentName+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 hiding (Flag)+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 hiding (matchFileGlob)+import           Distribution.Version+import           Distribution.Verbosity+import           Distribution.Text++import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph(IsNode(..))++import           Text.PrettyPrint hiding ((<>))+import qualified Text.PrettyPrint as Disp+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import           Control.Monad+import qualified Data.Traversable as T+import           Control.Monad.State as State+import           Control.Exception+import           Data.List (groupBy)+import           Data.Either+import           Data.Function+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 (CSubLibName _) -> 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, [UnresolvedSourcePackage])+rebuildProjectConfig verbosity+                     distDirLayout@DistDirLayout {+                       distProjectRootDirectory,+                       distDirectory,+                       distProjectCacheFile,+                       distProjectCacheDirectory+                     }+                     cliConfig = do++    (projectConfig, localPackages) <-+      runRebuild distProjectRootDirectory $+      rerunIfChanged verbosity fileMonitorProjectConfig () $ do++        projectConfig <- phaseReadProjectConfig+        localPackages <- phaseReadLocalPackages projectConfig+        return (projectConfig, localPackages)++    return (projectConfig <> cliConfig, localPackages)++  where+    fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config")++    -- Read the cabal.project (or implicit config) and combine it with+    -- arguments from the command line+    --+    phaseReadProjectConfig :: Rebuild ProjectConfig+    phaseReadProjectConfig = do+      liftIO $ do+        info verbosity "Project settings changed, reconfiguring..."+        createDirectoryIfMissingVerbose verbosity True distDirectory+        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory++      readProjectConfig verbosity distDirLayout++    -- Look for all the cabal packages in the project+    -- some of which may be local src dirs, tarballs etc+    --+    phaseReadLocalPackages :: ProjectConfig -> Rebuild [UnresolvedSourcePackage]+    phaseReadLocalPackages projectConfig = do+      localCabalFiles <- findProjectPackages distDirLayout projectConfig+      mapM (readSourcePackage verbosity) localCabalFiles+++-- | 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+                   -> [UnresolvedSourcePackage]+                   -> IO ( ElaboratedInstallPlan  -- with store packages+                         , ElaboratedInstallPlan  -- with source packages+                         , ElaboratedSharedConfig )+                      -- ^ @(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) <-+        rerunIfChanged verbosity fileMonitorElaboratedPlan+                       (projectConfigMonitored, localPackages,+                        progsearchpath) $ do++          compilerEtc   <- phaseConfigureCompiler projectConfig+          _             <- phaseConfigurePrograms projectConfig compilerEtc+          (solverPlan, pkgConfigDB)+                        <- phaseRunSolver         projectConfig+                                                  compilerEtc+                                                  localPackages+          (elaboratedPlan,+           elaboratedShared) <- phaseElaboratePlan projectConfig+                                                   compilerEtc pkgConfigDB+                                                   solverPlan+                                                   localPackages++          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared+          return (elaboratedPlan, elaboratedShared)++      -- 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)++  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)+                   -> [UnresolvedSourcePackage]+                   -> Rebuild (SolverInstallPlan, PkgConfigDb)+    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       <- getSourcePackages verbosity withRepoCtx+                                 (solverSettingIndexState 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)+      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+            , let pkgname            = packageName pkg+                  testsEnabled       = lookupLocalPackageConfig+                                         packageConfigTests+                                         projectConfig pkgname+                  benchmarksEnabled  = lookupLocalPackageConfig+                                         packageConfigBenchmarks+                                         projectConfig pkgname+                  stanzas =+                    Map.fromList $+                      [ (TestStanzas, enabled)+                      | enabled <- flagToList testsEnabled ]+                   ++ [ (BenchStanzas , enabled)+                      | enabled <- flagToList benchmarksEnabled ]+            ]++    -- 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+                       -> [SourcePackage loc]+                       -> Rebuild ( ElaboratedInstallPlan+                                  , ElaboratedSharedConfig )+    phaseElaboratePlan ProjectConfig {+                         projectConfigShared,+                         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+                projectConfigLocalPackages+                (getMapMappend projectConfigSpecificPackage)+        let instantiatedPlan = instantiateInstallPlan 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)+                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb+getSourcePackages verbosity withRepoCtx idxState = do+    (sourcePkgDb, repos) <-+      liftIO $+        withRepoCtx $ \repoctx -> do+          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity+                                                                  repoctx idxState+          return (sourcePkgDb, repoContextRepos repoctx)++    monitorFiles . map monitorFile+                 . IndexUtils.getSourcePackagesMonitorFiles+                 $ repos+    return sourcePkgDb+++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.+    mapM_ 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, packageSource 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, packageSource 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)+        --TODO: [required eventually] finish remote tarball functionality+--        allRemoteTarballPkgs =+--          [ (pkgid, )+--          | (pkgid, RemoteTarballPackage ) <- 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 grp))+              . 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+                          ++ 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+             -> [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++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setIndependentGoals solverSettingIndependentGoals++      . setReorderGoals solverSettingReorderGoals++      . setCountConflicts solverSettingCountConflicts++        --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++      . 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+                                   . packageDescription)++      . addSetupCabalMinVersionConstraint (mkVersion [1,20])+          -- 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.++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | Dependency 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 = packageName 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 = packageName 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 (null flags)+          , pkg <- localPackages+          , let pkgname = packageName 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+        (map SpecificSourcePackage localPackages)+++------------------------------------------------------------------------------+-- * 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.+--+-- However, we do have the following INVARIANT: a component never directly+-- depends on multiple versions of the same package.  Thus, 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.  The solver probably+-- doesn't handle this correctly... but it should.  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.  Fortunately, this doesn't seem to have affected anyone,+-- but it is good to watch out about.+++-- | 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+  -> [SourcePackage loc]+  -> Map PackageId PackageSourceHash+  -> InstallDirs.InstallDirTemplates+  -> ProjectConfigShared+  -> PackageConfig+  -> Map PackageName PackageConfig+  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)+elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB+                     DistDirLayout{..}+                     storeDirLayout@StoreDirLayout{storePackageDBStack}+                     solverPlan localPackages+                     sourcePackageHashes+                     defaultInstallDirs+                     sharedPackageConfig+                     localPackagesConfig+                     perPackageConfig = do+    x <- elaboratedInstallPlan+    return (x, elaboratedSharedConfig)+  where+    elaboratedSharedConfig =+      ElaboratedSharedConfig {+        pkgConfigPlatform      = platform,+        pkgConfigCompiler      = compiler,+        pkgConfigCompilerProgs = compilerprogdb+      }++    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 (disp (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" <+> disp 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 mapDep 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_custom ++ cuz_spec ++ cuz_length ++ cuz_flag+          where+            cuz reason = [text reason]+            -- 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_custom =+                case PD.buildType (elabPkgDescription elab0) of+                    Nothing        -> cuz "build-type is not specified"+                    Just PD.Custom -> cuz "build-type is Custom"+                    Just _         -> []+            -- 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 >= mkVersion [1,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"++        -- | 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 (CSubLibName _) = 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 mapDep 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+            | fromMaybe PD.Custom (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_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 path <- [Map.lookup (ann_id aid') exe_map1]]+                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 $+                            display pkgid ++ "-inplace" +++                              (case Cabal.componentNameString cname of+                                  Nothing -> ""+                                  Just s -> "-" ++ display 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: " ++ display 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+                elab = 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))+                      },+                    elabInstallDirs = install_dirs cid+                   }++            -- 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+            -- TODO: The fact that lib SolverIds and exe SolverIds are+            -- jammed together here means that we're losing information!+            external_dep_sids = external_lib_dep_sids ++ external_exe_dep_sids+            external_dep_pkgs = concatMap mapDep external_dep_sids++            external_exe_map = Map.fromList $+                [ (getComponentId pkg, path)+                | pkg <- external_dep_pkgs+                , Just path <- [planPackageExePath pkg] ]+            exe_map1 = Map.union external_exe_map exe_map++            external_cc_map = Map.fromListWith Map.union+                            $ map mkCCMapping external_dep_pkgs+            external_lc_map = Map.fromList (map mkShapeMapping external_dep_pkgs)++            compPkgConfigDependencies =+                [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "+                                            ++ display pn ++ " from "+                                            ++ display (elabPkgSourceId elab0))+                                 (pkgConfigDbPkgVersion pkgConfigDB pn))+                | PkgconfigDependency pn _ <- PD.pkgconfigDepends+                                                (Cabal.componentBuildInfo comp) ]++            install_dirs cid+              | shouldBuildInplaceOnly spkg+              -- use the ordinary default install dirs+              = (InstallDirs.absoluteInstallDirs+                   pkgid+                   (newSimpleUnitId cid)+                   (compilerInfo compiler)+                   InstallDirs.NoCopyDest+                   platform+                   defaultInstallDirs) {++                  -- absoluteInstallDirs sets these as 'undefined' but we have+                  -- to use them as "Setup.hs configure" args+                  InstallDirs.libsubdir  = "",+                  InstallDirs.libexecsubdir  = "",+                  InstallDirs.datasubdir = ""+                }++              | otherwise+              -- use special simplified install dirs+              = storePackageInstallDirs+                  storeDirLayout+                  (compilerId compiler)+                  cid++            -- 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.+            inplace_bin_dir elab+              | shouldBuildInplaceOnly spkg+              = distBuildDirectory+                    (elabDistDirParams elaboratedSharedConfig elab) </>+                    "build" </> case Cabal.componentNameString cname of+                                    Just n -> display n+                                    Nothing -> ""+              | otherwise+              = InstallDirs.bindir (elabInstallDirs elab)++    -- | 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)) . mapDep++    -- | Given an 'ElaboratedPlanPackage', return the path to where the+    -- executable that this package represents would be installed.+    planPackageExePath :: ElaboratedPlanPackage -> Maybe FilePath+    planPackageExePath =+        -- Pre-existing executables are assumed to be in PATH+        -- already.  In fact, this should be impossible.+        -- Modest duplication with 'inplace_bin_dir'+        InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $+            if elabBuildStyle elab == BuildInplaceOnly+              then distBuildDirectory+                    (elabDistDirParams elaboratedSharedConfig elab) </>+                    "build" </>+                        case elabPkgOrComp elab of+                            ElabPackage _ -> ""+                            ElabComponent comp ->+                                case fmap Cabal.componentNameString+                                          (compComponentName comp) of+                                    Just (Just n) -> display n+                                    _ -> ""+              else InstallDirs.bindir (elabInstallDirs elab)++    elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])+                             -> SolverPackage UnresolvedPkgLoc+                             -> ComponentsGraph+                             -> [ElaboratedConfiguredPackage]+                             -> ElaboratedConfiguredPackage+    elaborateSolverToPackage+        mapDep+        pkg@(SolverPackage (SourcePackage pkgid _gdesc _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 mapDep pkg+        elab = elab0 {+                elabUnitId = newSimpleUnitId pkgInstalledId,+                elabComponentId = pkgInstalledId,+                elabLinkedInstantiatedWith = Map.empty,+                elabInstallDirs = install_dirs,+                elabPkgOrComp = ElabPackage $ ElaboratedPackage {..},+                elabModuleShape = modShape+            }++        modShape = case find (matchElabPkg (== CLibName)) comps of+                        Nothing -> emptyModuleShape+                        Just e -> Ty.elabModuleShape e++        pkgInstalledId+          | shouldBuildInplaceOnly pkg+          = mkComponentId (display 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: " ++ display 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 ]+            is_lib CLibName = True+            -- NB: this case should not occur, because sub-libraries+            -- are not supported without per-component builds+            is_lib (CSubLibName _) = True+            is_lib _ = False++        buildComponentDeps f+            = CD.fromList [ (compSolverName comp, f comp)+                          | ElaboratedConfiguredPackage{+                                elabPkgOrComp = ElabComponent comp+                            } <- comps+                          ]++        -- Filled in later+        pkgStanzasEnabled  = Set.empty++        install_dirs+          | shouldBuildInplaceOnly pkg+          -- use the ordinary default install dirs+          = (InstallDirs.absoluteInstallDirs+               pkgid+               (newSimpleUnitId pkgInstalledId)+               (compilerInfo compiler)+               InstallDirs.NoCopyDest+               platform+               defaultInstallDirs) {++              -- absoluteInstallDirs sets these as 'undefined' but we have to+              -- use them as "Setup.hs configure" args+              InstallDirs.libsubdir  = "",+              InstallDirs.libexecsubdir = "",+              InstallDirs.datasubdir = ""+            }++          | otherwise+          -- use special simplified install dirs+          = storePackageInstallDirs+              storeDirLayout+              (compilerId compiler)+              pkgInstalledId++    elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage])+                            -> SolverPackage UnresolvedPkgLoc+                            -> ElaboratedConfiguredPackage+    elaborateSolverToCommon mapDep+        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  = let Right (desc, _) =+                                    PD.finalizePD+                                    flags elabEnabledSpec (const True)+                                    platform (compilerInfo compiler)+                                    [] gdesc+                               in desc+        elabFlagAssignment  = flags+        elabFlagDefaults    = [ (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.+        elabBuildTargets    = []+        elabTestTargets     = []+        elabReplTarget      = Nothing+        elabBuildHaddocks   = False++        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+        -- Computing the deps here is a little awful+        deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0+        elabSetupScriptCliVersion  = packageSetupScriptSpecVersion+                                      elabSetupScriptStyle elabPkgDescription deps+        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+        elabDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe+        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+        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+        elabHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables+        elabHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites+        elabHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks+        elabHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal+        elabHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss+        elabHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour+        elabHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss+        elabHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents++    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+      -- the project config specifies values that apply to packages local to+      -- but by default non-local packages get all default config values+      -- the project, and can specify per-package values for any package,+      | isLocalToProject pkg = local `mappend` perpkg+      | otherwise            =                 perpkg+      where+        local  = f localPackagesConfig+        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+          [ PlannedId (packageId pkg)+          | pkg <- localPackages ]++    isLocalToProject :: Package pkg => pkg -> Bool+    isLocalToProject pkg = Set.member (packageId pkg)+                                      pkgsLocalToProject++    pkgsLocalToProject :: Set PackageId+    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]++    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++-- | 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 ipkg =+    case IPI.sourceLibName ipkg of+        Nothing -> CLibName+        Just n  -> (CSubLibName n)++-- | 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 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)])++-- | 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 :: ElaboratedInstallPlan -> ElaboratedInstallPlan+instantiateInstallPlan 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 (elab@ElaboratedConfiguredPackage+                                    { elabPkgOrComp = ElabComponent comp }) -> do+            deps <- mapM (substUnitId insts)+                         (compLinkedLibDependencies comp)+            let getDep (Module dep_uid _) = [dep_uid]+            return $ InstallPlan.Configured elab {+                    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)))+                    }+                }+          _ -> return planpkg+      | otherwise = error ("instantiateComponent: " ++ display 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 = T.mapM (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+      | Just planpkg <- Map.lookup cid cmap+      = return planpkg+      | otherwise = error ("indefiniteComponent: " ++ display cid)++    ready_map = execState work Map.empty++    work = forM_ 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+        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 (componentName component) 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"+      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   -> 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) [ () | 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 = TargetActionBuild+                  | TargetActionRepl+                  | TargetActionTest+                  | 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.+--+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,  TargetActionBuild)   -> elab { elabBuildTargets = tgts }+        (Just tgts,  TargetActionTest)    -> elab { elabTestTargets  = tgts }+        (Just [tgt], TargetActionRepl)    -> elab { elabReplTarget = Just tgt }+        (Just _,     TargetActionHaddock) -> elab { elabBuildHaddocks = True }+        (Just _,     TargetActionRepl)    ->+          error "pruneInstallPlanToTargets: multiple repl targets"++-- | 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' = pruneOptionalStanzas elab++    find_root (InstallPlan.Configured (PrunedPackage elab _)) =+        if not (null (elabBuildTargets elab)+                    && null (elabTestTargets elab)+                    && isNothing (elabReplTarget elab)+                    && not (elabBuildHaddocks elab))+            then Just (installedUnitId elab)+            else Nothing+    find_root _ = Nothing++    -- Decide whether or not to enable testsuites and benchmarks+    --+    -- 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.+    --+    pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage+    pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =+        elab {+            elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })+        }+      where+        stanzas :: Set OptionalStanza+        stanzas = optionalStanzasRequiredByTargets  elab+               <> optionalStanzasRequestedByDefault elab+               <> optionalStanzasWithDepsAvailable availablePkgs elab pkg+    pruneOptionalStanzas 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+                                  ++ maybeToList (elabReplTarget pkg)+        , stanza <- maybeToList (componentOptionalStanza cname)+        ]++    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage+                                      -> Set OptionalStanza+    optionalStanzasRequestedByDefault =+        Map.keysSet+      . Map.filter (id :: Bool -> Bool)+      . elabStanzasRequested++    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 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++componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza+componentOptionalStanza (Cabal.CTestName  _) = Just TestStanzas+componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas+componentOptionalStanza _                    = Nothing++------------------------------------+-- 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 = catMaybes (map 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. 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 = ...  -- 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++  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against+  = SetupNonCustomExternalLib++  | otherwise+  = SetupNonCustomInternalLib+  where+    buildType = fromMaybe PD.Custom (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+        | depPkgname <- legacyCustomSetupPkgs compiler platform ] +++        [ Dependency cabalPkgname cabalConstraint+        | 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 (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+             , Dependency basePkgname  anyVersion ]+        where+          cabalConstraint = orLaterVersion (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: " ++ display (packageId pkg)+++-- | Work out which version of the Cabal spec 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 :: Package pkg+                              => SetupScriptStyle+                              -> PD.PackageDescription+                              -> ComponentDeps [pkg]+                              -> 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 deps =+    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of+      Just dep -> packageVersion dep+      Nothing  -> PD.specVersion pkg+++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", "old-time", "pretty"+        , "process", "time", "transformers" ]+     ++ [ "Win32" | os == Windows ]+     ++ [ "unix"  | os /= Windows ]+     ++ [ "ghc-prim"         | isGHC ]+     ++ [ "template-haskell" | isGHC ]+  where+    isGHC = compilerCompatFlavor GHC compiler++-- 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+                     -> ElaboratedSharedConfig+                     -> 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{..})+                     ElaboratedSharedConfig{..} 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) uid+                                 <- elabSetupDependencies elab ],+      useDependenciesExclusive = True,+      useVersionMacros         = elabSetupScriptStyle == SetupCustomExplicitDeps,+      useProgramDb             = pkgConfigCompilerProgs,+      useDistPref              = builddir,+      useLoggingHandle         = Nothing, -- this gets set later+      useWorkingDir            = Just srcdir,+      useExtraPathEnv          = elabExeDependencyPaths elab,+      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{storePackageDirectory}+                        compid ipkgid =+    InstallDirs.InstallDirs {..}+  where+    prefix       = storePackageDirectory compid (newSimpleUnitId ipkgid)+    bindir       = prefix </> "bin"+    libdir       = prefix </> "lib"+    libsubdir    = ""+    dynlibdir    = 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"+++--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 (display (pkgInstalledId pkg))+                                  ElabComponent _ -> mempty+    configCID                 = case elabPkgOrComp of+                                  ElabPackage _ -> mempty+                                  ElabComponent _ -> toFlag elabComponentId++    configProgramPaths        = Map.toList elabProgramPaths+    configProgramArgs         = 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+    configDynExe              = toFlag elabDynExe+    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+    configSplitObjs           = toFlag elabSplitObjs+    configStripExes           = toFlag elabStripExes+    configStripLibs           = toFlag elabStripLibs+    configDebugInfo           = toFlag elabDebugInfo+    configAllowOlder          = mempty -- we use configExactConfiguration True+    configAllowNewer          = mempty -- we use configExactConfiguration True++    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        = [ (case mb_cn of+                                    -- Special case for internal libraries+                                    Just (CSubLibName uqn)+                                        | packageId elab == srcid+                                        -> mkPackageName (unUnqualComponentName uqn)+                                    _ -> packageName srcid,+                                   cid)+                                | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab ]+    configConstraints         =+        case elabPkgOrComp of+            ElabPackage _ ->+                [ thisPackageVersion 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+++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+    }+++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 _ _ verbosity builddir = Cabal.TestFlags+    { testDistPref    = toFlag builddir+    , testVerbosity   = toFlag verbosity+    , testMachineLog  = mempty+    , testHumanLog    = mempty+    , testShowDetails = toFlag Cabal.Always+    , testKeepTix     = mempty+    , testOptions     = mempty+    }++setupHsTestArgs :: ElaboratedConfiguredPackage -> [String]+-- TODO: Does the issue #3335 affects test as well+setupHsTestArgs elab =+    mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)++setupHsReplFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.ReplFlags+setupHsReplFlags _ _ 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+    }+++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+    }++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+    }++setupHsHaddockFlags :: ElaboratedConfiguredPackage+                    -> ElaboratedSharedConfig+                    -> Verbosity+                    -> FilePath+                    -> Cabal.HaddockFlags+-- TODO: reconsider whether or not Executables/TestSuites/...+-- needed for component+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    = mempty, --TODO: new flag+      haddockForeignLibs   = toFlag elabHaddockForeignLibs,+      haddockExecutables   = toFlag elabHaddockExecutables,+      haddockTestSuites    = toFlag elabHaddockTestSuites,+      haddockBenchmarks    = toFlag elabHaddockBenchmarks,+      haddockInternal      = toFlag elabHaddockInternal,+      haddockCss           = maybe mempty toFlag elabHaddockCss,+      haddockHscolour      = toFlag elabHaddockHscolour,+      haddockHscolourCss   = maybe mempty toFlag elabHaddockHscolourCss,+      haddockContents      = maybe mempty toFlag elabHaddockContents,+      haddockDistPref      = toFlag builddir,+      haddockKeepTempFiles = mempty, --TODO: from build settings+      haddockVerbosity     = toFlag verbosity+    }++{-+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. "+         ++ display (packageId pkg)++packageHashConfigInputs :: ElaboratedSharedConfig+                        -> ElaboratedConfiguredPackage+                        -> PackageHashConfigInputs+packageHashConfigInputs+    ElaboratedSharedConfig{..}+    ElaboratedConfiguredPackage{..} =++    PackageHashConfigInputs {+      pkgHashCompilerId          = compilerId pkgConfigCompiler,+      pkgHashPlatform            = pkgConfigPlatform,+      pkgHashFlagAssignment      = elabFlagAssignment,+      pkgHashConfigureScriptArgs = elabConfigureScriptArgs,+      pkgHashVanillaLib          = elabVanillaLib,+      pkgHashSharedLib           = elabSharedLib,+      pkgHashDynExe              = elabDynExe,+      pkgHashGHCiLib             = elabGHCiLib,+      pkgHashProfLib             = elabProfLib,+      pkgHashProfExe             = elabProfExe,+      pkgHashProfLibDetail       = elabProfLibDetail,+      pkgHashProfExeDetail       = elabProfExeDetail,+      pkgHashCoverage            = elabCoverage,+      pkgHashOptimization        = elabOptimization,+      pkgHashSplitObjs           = elabSplitObjs,+      pkgHashStripLibs           = elabStripLibs,+      pkgHashStripExes           = elabStripExes,+      pkgHashDebugInfo           = elabDebugInfo,+      pkgHashProgramArgs         = elabProgramArgs,+      pkgHashExtraLibDirs        = elabExtraLibDirs,+      pkgHashExtraFrameworkDirs  = elabExtraFrameworkDirs,+      pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,+      pkgHashProgPrefix          = elabProgPrefix,+      pkgHashProgSuffix          = elabProgSuffix+    }+++-- | 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.
Distribution/Client/ProjectPlanning/Types.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}  -- | Types used while planning how to build everything in a project. --@@ -10,46 +12,69 @@     -- * Elaborated install plan types     ElaboratedInstallPlan,     ElaboratedConfiguredPackage(..),++    elabDistDirParams,+    elabExeDependencyPaths,+    elabLibDependencies,+    elabOrderLibDependencies,+    elabExeDependencies,+    elabOrderExeDependencies,+    elabSetupDependencies,+    elabPkgConfigDependencies,+    elabInplaceDependencyBuildCacheFiles,+    elabRequiresRegistration,++    elabPlanPackageName,+    elabConfiguredName,+    elabComponentName,++    ElaboratedPackageOrComponent(..),+    ElaboratedComponent(..),+    ElaboratedPackage(..),+    pkgOrderDependencies,     ElaboratedPlanPackage,     ElaboratedSharedConfig(..),     ElaboratedReadyPackage,     BuildStyle(..),     CabalFileText, -    -- * Types used in executing an install plan-    --TODO: [code cleanup] these types should live with execution, not with-    --      plan definition. Need to better separate InstallPlan definition.-    GenericBuildResult(..),-    BuildResult,-    BuildSuccess(..),-    BuildFailure(..),-    DocsResult(..),-    TestsResult(..),-     -- * Build targets-    PackageTarget(..),     ComponentTarget(..),+    showComponentTarget,+    showTestComponentTarget,     SubComponentTarget(..), +    isTestComponentTarget,+     -- * Setup script     SetupScriptStyle(..),   ) where +import           Distribution.Client.TargetSelector+                   ( SubComponentTarget(..) ) import           Distribution.Client.PackageHash  import           Distribution.Client.Types-                   hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)-                          , DocsResult(..), TestsResult(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, InstallPlan, GenericPlanPackage )-import           Distribution.Client.ComponentDeps (ComponentDeps)+                   ( GenericInstallPlan, GenericPlanPackage(..) )+import           Distribution.Client.SolverInstallPlan+                   ( SolverInstallPlan )+import           Distribution.Client.DistDirLayout +import           Distribution.Backpack+import           Distribution.Backpack.ModuleShape++import           Distribution.Verbosity+import           Distribution.Text+import           Distribution.Types.ComponentRequestedSpec import           Distribution.Package                    hiding (InstalledPackageId, installedPackageId) import           Distribution.System import qualified Distribution.PackageDescription as Cabal import           Distribution.InstalledPackageInfo (InstalledPackageInfo) import           Distribution.Simple.Compiler+import qualified Distribution.Simple.BuildTarget as Cabal import           Distribution.Simple.Program.Db import           Distribution.ModuleName (ModuleName) import           Distribution.Simple.LocalBuildInfo (ComponentName(..))@@ -57,23 +82,23 @@ import           Distribution.Simple.InstallDirs (PathTemplate) 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           Data.Map (Map) import           Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import           Distribution.Compat.Binary import           GHC.Generics (Generic)-import           Data.Typeable (Typeable)-import           Control.Exception+import qualified Data.Monoid as Mon+import           Data.Typeable+import           Control.Monad   --- | The type of install plan produced by the solver and used as the starting--- point for the 'ElaboratedInstallPlan'.----type SolverInstallPlan-   = InstallPlan --TODO: [code cleanup] redefine locally or move def to solver interface-- -- | 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.@@ -84,13 +109,21 @@ type ElaboratedInstallPlan    = GenericInstallPlan InstalledPackageInfo                         ElaboratedConfiguredPackage-                        BuildSuccess BuildFailure  type ElaboratedPlanPackage    = GenericPlanPackage InstalledPackageInfo                         ElaboratedConfiguredPackage-                        BuildSuccess BuildFailure +-- | User-friendly display string for an 'ElaboratedPlanPackage'.+elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String+elabPlanPackageName verbosity (PreExisting ipkg)+    | verbosity <= normal = display (packageName ipkg)+    | otherwise           = display (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@@ -104,136 +137,463 @@        -- used.        pkgConfigCompilerProgs :: ProgramDb      }-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)   --TODO: [code cleanup] no Eq instance  instance Binary ElaboratedSharedConfig  data ElaboratedConfiguredPackage    = ElaboratedConfiguredPackage {--       pkgInstalledId :: InstalledPackageId,-       pkgSourceId    :: PackageId,+       -- | The 'UnitId' which uniquely identifies this item in a build plan+       elabUnitId        :: UnitId, -       -- | TODO: [code cleanup] we don't need this, just a few bits from it:-       --   build type, spec version-       pkgDescription :: Cabal.PackageDescription,+       elabComponentId :: ComponentId,+       elabInstantiatedWith :: Map ModuleName Module,+       elabLinkedInstantiatedWith :: Map ModuleName OpenModule, -       -- | A total flag assignment for the package-       pkgFlagAssignment   :: Cabal.FlagAssignment,+       -- | 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 original default flag assignment, used only for reporting.-       pkgFlagDefaults     :: Cabal.FlagAssignment,+       -- | The 'PackageId' of the originating package+       elabPkgSourceId    :: PackageId, -       -- | The exact dependencies (on other plan packages)-       ---       pkgDependencies     :: ComponentDeps [ConfiguredId],+       -- | Shape of the package/component, for Backpack.+       elabModuleShape    :: ModuleShape, -       -- | 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.-       pkgStanzasAvailable :: Set OptionalStanza,+       -- | 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, -       -- | 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.-       pkgStanzasRequested :: Map OptionalStanza Bool,+       -- | The original default flag assignment, used only for reporting.+       elabFlagDefaults     :: Cabal.FlagAssignment, -       -- | Which optional stanzas (ie testsuites, benchmarks) will actually-       -- be enabled during the package configure step.-       pkgStanzasEnabled :: Set OptionalStanza,+       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.-       pkgSourceLocation :: PackageLocation (Maybe FilePath),+       elabPkgSourceLocation :: PackageLocation (Maybe FilePath),         -- | The hash of the source, e.g. the tarball. We don't have this for        -- local source dir packages.-       pkgSourceHash     :: Maybe PackageSourceHash,+       elabPkgSourceHash     :: Maybe PackageSourceHash, -       --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+       -- | 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, -       pkgBuildStyle             :: BuildStyle,+       -- | 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, -       pkgSetupPackageDBStack    :: PackageDBStack,-       pkgBuildPackageDBStack    :: PackageDBStack,-       pkgRegisterPackageDBStack :: PackageDBStack,+       -- | Another way of phrasing 'pkgStanzasAvailable'.+       elabEnabledSpec      :: ComponentRequestedSpec, -       -- | The package contains a library and so must be registered-       pkgRequiresRegistration :: Bool,-       pkgDescriptionOverride  :: Maybe CabalFileText,+       -- | 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, -       pkgVanillaLib           :: Bool,-       pkgSharedLib            :: Bool,-       pkgDynExe               :: Bool,-       pkgGHCiLib              :: Bool,-       pkgProfLib              :: Bool,-       pkgProfExe              :: Bool,-       pkgProfLibDetail        :: ProfDetailLevel,-       pkgProfExeDetail        :: ProfDetailLevel,-       pkgCoverage             :: Bool,-       pkgOptimization         :: OptimisationLevel,-       pkgSplitObjs            :: Bool,-       pkgStripLibs            :: Bool,-       pkgStripExes            :: Bool,-       pkgDebugInfo            :: DebugInfoLevel,+       -- | 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, -       pkgProgramPaths          :: Map String FilePath,-       pkgProgramArgs           :: Map String [String],-       pkgProgramPathExtra      :: [FilePath],-       pkgConfigureScriptArgs   :: [String],-       pkgExtraLibDirs          :: [FilePath],-       pkgExtraFrameworkDirs    :: [FilePath],-       pkgExtraIncludeDirs      :: [FilePath],-       pkgProgPrefix            :: Maybe PathTemplate,-       pkgProgSuffix            :: Maybe PathTemplate,+       elabSetupPackageDBStack    :: PackageDBStack,+       elabBuildPackageDBStack    :: PackageDBStack,+       elabRegisterPackageDBStack :: PackageDBStack, -       pkgInstallDirs           :: InstallDirs.InstallDirs FilePath,+       elabPkgDescriptionOverride  :: Maybe CabalFileText, -       pkgHaddockHoogle         :: Bool,-       pkgHaddockHtml           :: Bool,-       pkgHaddockHtmlLocation   :: Maybe String,-       pkgHaddockExecutables    :: Bool,-       pkgHaddockTestSuites     :: Bool,-       pkgHaddockBenchmarks     :: Bool,-       pkgHaddockInternal       :: Bool,-       pkgHaddockCss            :: Maybe FilePath,-       pkgHaddockHscolour       :: Bool,-       pkgHaddockHscolourCss    :: Maybe FilePath,-       pkgHaddockContents       :: Maybe PathTemplate,+       -- TODO: make per-component variants of these flags+       elabVanillaLib           :: Bool,+       elabSharedLib            :: Bool,+       elabDynExe               :: Bool,+       elabGHCiLib              :: Bool,+       elabProfLib              :: Bool,+       elabProfExe              :: Bool,+       elabProfLibDetail        :: ProfDetailLevel,+       elabProfExeDetail        :: ProfDetailLevel,+       elabCoverage             :: Bool,+       elabOptimization         :: OptimisationLevel,+       elabSplitObjs            :: 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,+       elabHaddockExecutables    :: Bool,+       elabHaddockTestSuites     :: Bool,+       elabHaddockBenchmarks     :: Bool,+       elabHaddockInternal       :: Bool,+       elabHaddockCss            :: Maybe FilePath,+       elabHaddockHscolour       :: Bool,+       elabHaddockHscolourCss    :: Maybe FilePath,+       elabHaddockContents       :: Maybe 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.-       pkgSetupScriptStyle      :: SetupScriptStyle,+       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.-       pkgSetupScriptCliVersion :: Version,+       elabSetupScriptCliVersion :: Version,         -- Build time related:-       pkgBuildTargets          :: [ComponentTarget],-       pkgReplTarget            :: Maybe ComponentTarget,-       pkgBuildHaddocks         :: Bool-     }-  deriving (Eq, Show, Generic)+       elabBuildTargets          :: [ComponentTarget],+       elabTestTargets           :: [ComponentTarget],+       elabReplTarget            :: Maybe ComponentTarget,+       elabBuildHaddocks         :: Bool, -instance Binary ElaboratedConfiguredPackage+       --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)++-- | 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.+            build_target || 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 (CSubLibName _) = True+    is_lib _ = False+ instance Package ElaboratedConfiguredPackage where-  packageId = pkgSourceId+  packageId = elabPkgSourceId +instance HasConfiguredId ElaboratedConfiguredPackage where+  configuredId elab =+    ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab)+ instance HasUnitId ElaboratedConfiguredPackage where-  installedUnitId = pkgInstalledId+  installedUnitId = elabUnitId -instance PackageFixedDeps ElaboratedConfiguredPackage where-  depends = fmap (map installedPackageId) . pkgDependencies+instance IsNode ElaboratedConfiguredPackage where+    type Key ElaboratedConfiguredPackage = UnitId+    nodeKey = elabUnitId+    nodeNeighbors = elabOrderDependencies +instance Binary ElaboratedConfiguredPackage++data ElaboratedPackageOrComponent+    = ElabPackage   ElaboratedPackage+    | ElabComponent ElaboratedComponent+  deriving (Eq, Show, Generic)++instance Binary ElaboratedPackageOrComponent++elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName+elabComponentName elab =+    case elabPkgOrComp elab of+        ElabPackage _      -> Just CLibName -- 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 -> ""+                Just cname -> display cname ++ " from ")+      ++ display (packageId elab)+    | otherwise+    = display (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 _      -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab)+        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 Version)]+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 Version)],+    -- | The paths all our executable dependencies will be installed+    -- to once they are installed.+    compExeDependencyPaths :: [(ConfiguredId, FilePath)],+    compOrderLibDependencies :: [UnitId]+   }+  deriving (Eq, Show, Generic)++instance Binary 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 Version)],++       -- | 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++-- | 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. --@@ -261,83 +621,41 @@ type CabalFileText = LBS.ByteString  type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage-                                                  InstalledPackageInfo ---TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan--- because the same ipkg is used by many packages. So the binary file will be big.--- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo?--- or transform to a shared form when serialising / deserialising -data GenericBuildResult ipkg iresult ifailure-                  = BuildFailure ifailure-                  | BuildSuccess (Maybe ipkg) iresult-  deriving (Eq, Show, Generic)--instance (Binary ipkg, Binary iresult, Binary ifailure) =>-         Binary (GenericBuildResult ipkg iresult ifailure)--type BuildResult  = GenericBuildResult InstalledPackageInfo -                                       BuildSuccess BuildFailure--data BuildSuccess = BuildOk DocsResult TestsResult-  deriving (Eq, Show, Generic)--data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-  deriving (Eq, Show, Generic)--data TestsResult = TestsNotTried | TestsOk-  deriving (Eq, Show, Generic)--data BuildFailure = PlanningFailed              --TODO: [required eventually] not yet used-                  | DependentFailed PackageId-                  | DownloadFailed  String      --TODO: [required eventually] not yet used-                  | UnpackFailed    String      --TODO: [required eventually] not yet used-                  | ConfigureFailed String-                  | BuildFailed     String-                  | TestsFailed     String      --TODO: [required eventually] not yet used-                  | InstallFailed   String-  deriving (Eq, Show, Typeable, Generic)--instance Exception BuildFailure--instance Binary BuildFailure-instance Binary BuildSuccess-instance Binary DocsResult-instance Binary TestsResult-- --------------------------- -- Build targets -- --- | The various targets within a package. This is more of a high level--- specification than a elaborated prescription.+-- | Specific targets within a package or component to act on e.g. to build,+-- haddock or open a repl. ---data PackageTarget =-     -- | Build the default components in this package. This usually means-     -- just the lib and exes, but it can also mean the testsuites and-     -- benchmarks if the user explicitly requested them.-     BuildDefaultComponents-     -- | Build a specific component in this package.-   | BuildSpecificComponent ComponentTarget-   | ReplDefaultComponent-   | ReplSpecificComponent  ComponentTarget-   | HaddockDefaultComponents-  deriving (Eq, Show, Generic)- data ComponentTarget = ComponentTarget ComponentName SubComponentTarget-  deriving (Eq, Show, Generic)--data SubComponentTarget = WholeComponent-                        | ModuleTarget ModuleName-                        | FileTarget   FilePath-  deriving (Eq, Show, Generic)+  deriving (Eq, Ord, Show, Generic) -instance Binary PackageTarget instance Binary ComponentTarget-instance Binary SubComponentTarget +-- | 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 $ display n+showTestComponentTarget _ _ = Nothing++isTestComponentTarget :: ComponentTarget -> Bool+isTestComponentTarget (ComponentTarget (CTestName _) _) = True+isTestComponentTarget _                                 = False+ --------------------------- -- Setup.hs script policy --@@ -363,7 +681,7 @@                       | SetupCustomImplicitDeps                       | SetupNonCustomExternalLib                       | SetupNonCustomInternalLib-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Typeable)  instance Binary SetupScriptStyle
Distribution/Client/RebuildMonad.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | An abstraction for re-running actions if values or files have changed.@@ -13,6 +12,7 @@     -- * Rebuild monad     Rebuild,     runRebuild,+    execRebuild,     askRoot,      -- * Setting up file monitoring@@ -42,8 +42,20 @@      -- * Utils     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)@@ -51,13 +63,10 @@ import Distribution.Simple.Utils (debug) import Distribution.Verbosity    (Verbosity) -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad.State as State import Control.Monad.Reader as Reader-import Distribution.Compat.Binary     (Binary)-import System.FilePath (takeFileName)+import System.FilePath+import System.Directory   -- | A monad layered on top of 'IO' to help with re-running actions when the@@ -86,6 +95,10 @@ 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@@ -145,3 +158,80 @@     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 view
@@ -0,0 +1,235 @@+module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where++import Control.Monad ( unless, when )+import Data.Maybe ( isJust )+import Data.Monoid hiding ( (<>) )+import System.Directory ( doesFileExist )++import Distribution.Compat.Semigroup++import Distribution.Verbosity++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+       ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath+       , maybeReinstallAddSourceDeps, updateInstallDirs )+import Distribution.Client.Sandbox.PackageEnvironment+       ( userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types ( UseSandbox(..) )+import Distribution.Client.Setup+       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..)+       , SkipAddSourceDepsCheck(..) )+++-- | @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+  -> UseSandbox+  -> SkipAddSourceDepsCheck+     -- ^ Should we skip the timestamp check for modified+     -- add-source dependencies?+  -> 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+  useSandbox+  skipAddSourceDepsCheck+  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+            <> checkAddSourceDeps+      (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags++      let (_, config') =+            updateInstallDirs+            (configUserInstall configFlags)+            (useSandbox, config)++      when force $ 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 configuration older than the sandbox configuration file?+      -- If so, reconfiguration is required.+      sandboxConfig <- getSandboxConfigFilePath globalFlags+      sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig+      when sandboxConfigNewer $+        info verbosity "sandbox was created after the package was 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 sandboxConfigNewer+            <> Any (not configured)+      return (failed, flags)++    checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do+      let (_, config') =+            updateInstallDirs+            (configUserInstall configFlags)+            (useSandbox, config)++          skipAddSourceDepsCheck'+            | force'    = SkipAddSourceDepsCheck+            | otherwise = skipAddSourceDepsCheck++      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $+        info verbosity "skipping add-source deps check"++      -- Were any add-source dependencies reinstalled in the sandbox?+      depsReinstalled <-+        case skipAddSourceDepsCheck' of+          DontSkipAddSourceDepsCheck ->+            maybeReinstallAddSourceDeps+            verbosity numJobsFlag configFlags globalFlags+            (useSandbox, config')+          SkipAddSourceDepsCheck -> do+            return NoDepsReinstalled++      case depsReinstalled of+        NoDepsReinstalled -> return (mempty, flags)+        ReinstalledSomeDeps -> do+          info verbosity "some add-source dependencies were reinstalled"+          return (Any True, flags)
Distribution/Client/Run.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Run@@ -11,8 +10,15 @@ 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(..),@@ -23,21 +29,16 @@ import Distribution.Simple.BuildPaths        (exeExtension) import Distribution.Simple.LocalBuildInfo    (ComponentName (..),                                               LocalBuildInfo (..),-                                              getComponentLocalBuildInfo,                                               depLibraryPaths)-import Distribution.Simple.Utils             (die, notice, warn,+import Distribution.Simple.Utils             (die', notice, warn,                                               rawSystemExitWithEnv,                                               addLibraryPath) import Distribution.System                   (Platform (..)) import Distribution.Verbosity                (Verbosity)+import Distribution.Text                     (display)  import qualified Distribution.Simple.GHCJS as GHCJS -#if !MIN_VERSION_base(4,8,0)-import Data.Functor                          ((<$>))-#endif-import Data.List                             (find)-import Data.Foldable                         (traverse_) import System.Directory                      (getCurrentDirectory) import Distribution.Compat.Environment       (getEnvironment) import System.FilePath                       ((<.>), (</>))@@ -51,7 +52,7 @@   case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)     Left err               -> do       warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.-      die err+      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"@@ -70,14 +71,14 @@       ([]   , _)           -> Left "Couldn't find any enabled executables."       ([exe], [])          -> return (False, exe, [])       ([exe], (x:xs))-        | x == exeName exe -> return (True, exe, xs)-        | otherwise        -> return (False, exe, args)-      (_    , [])          -> Left+        | 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 -> exeName exe == x) enabledExes of+        case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of           Nothing  -> Left $ "No executable named '" ++ x ++ "'."           Just exe -> return (True, exe, xs)       where@@ -86,20 +87,20 @@     maybeWarning :: Maybe String     maybeWarning = case args of       []    -> Nothing-      (x:_) -> lookup x components+      (x:_) -> lookup (mkUnqualComponentName x) components       where-        components :: [(String, String)] -- Component name, message.+        components :: [(UnqualComponentName, String)] -- Component name, message.         components =-          [ (name, "The executable '" ++ name ++ "' is disabled.")+          [ (name, "The executable '" ++ display name ++ "' is disabled.")           | e <- executables pkg_descr           , not . buildable . buildInfo $ e, let name = exeName e] -          ++ [ (name, "There is a test-suite '" ++ name ++ "',"+          ++ [ (name, "There is a test-suite '" ++ display name ++ "',"                       ++ " but the `run` command is only for executables.")              | t <- testSuites pkg_descr              , let name = testName t] -          ++ [ (name, "There is a benchmark '" ++ name ++ "',"+          ++ [ (name, "There is a benchmark '" ++ display name ++ "',"                       ++ " but the `run` command is only for executables.")              | b <- benchmarks pkg_descr              , let name = benchmarkName b]@@ -114,26 +115,29 @@                        curDir </> dataDir pkg_descr)    (path, runArgs) <--    case compilerFlavor (compiler lbi) of+    let exeName' = display $ exeName exe+    in case compilerFlavor (compiler lbi) of       GHCJS -> do         let (script, cmd, cmdArgs) =               GHCJS.runCmd (withPrograms lbi)-                           (buildPref </> exeName exe </> exeName exe)+                           (buildPref </> exeName' </> exeName')         script' <- tryCanonicalizePath script         return (cmd, cmdArgs ++ [script'])       _     -> do          p <- tryCanonicalizePath $-            buildPref </> exeName exe </> (exeName exe <.> exeExtension)+            buildPref </> exeName' </> (exeName' <.> exeExtension)          return (p, [])    env  <- (dataDirEnvVar:) <$> getEnvironment   -- Add (DY)LD_LIBRARY_PATH if needed   env' <- if withDynExe lbi              then do let (Platform _ os) = hostPlatform lbi-                         clbi = getComponentLocalBuildInfo lbi-                                  (CExeName (exeName exe))+                     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 " ++ exeName exe ++ "..."+  notice verbosity $ "Running " ++ display (exeName exe) ++ "..."   rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
Distribution/Client/Sandbox.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox@@ -38,12 +39,16 @@     updateSandboxConfigFileFlag,     updateInstallDirs, -    configPackageDB', configCompilerAux', getPersistOrConfigCompiler+    getPersistOrConfigCompiler   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.Setup   ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)-  , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags+  , GlobalFlags(..), configCompilerAux', configPackageDB'+  , defaultConfigExFlags, defaultInstallFlags   , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps                                               , maybeAddCompilerTimestampRecord@@ -70,59 +75,55 @@                                               , UseSandbox(..) ) import Distribution.Client.SetupWrapper   ( SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Types              ( PackageLocation(..)-                                              , SourcePackage(..) )+import Distribution.Client.Types              ( PackageLocation(..) ) import Distribution.Client.Utils              ( inDir, tryCanonicalizePath                                               , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription )-import Distribution.PackageDescription.Parse  ( readPackageDescription )-import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)-                                              , PackageDBStack )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )+#else+import Distribution.PackageDescription.Parse  ( readGenericPackageDescription )+#endif+import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure          ( configCompilerAuxEx-                                              , interpretPackageDbFlags                                               , getPackageDBContents                                               , maybeGetPersistBuildConfig                                               , findDistPrefOrDefault                                               , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess         ( knownSuffixHandlers )-import Distribution.Simple.Program            ( ProgramConfiguration )+import Distribution.Simple.Program            ( ProgramDb ) import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)                                               , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist            ( prepareTree )-import Distribution.Simple.Utils              ( die, debug, notice, info, warn+import Distribution.Simple.Utils              ( die', debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc-                                              , intercalate, topHandlerWith+                                              , topHandlerWith                                               , createDirectoryIfMissingVerbose ) import Distribution.Package                   ( Package(..) ) import Distribution.System                    ( Platform ) import Distribution.Text                      ( display )-import Distribution.Verbosity                 ( Verbosity, lessVerbose )+import Distribution.Verbosity                 ( Verbosity ) import Distribution.Compat.Environment        ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms   ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index import Distribution.Simple.PackageIndex       ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex import qualified Distribution.Simple.Register      as Register++import Distribution.Solver.Types.SourcePackage+ import qualified Data.Map                          as M import qualified Data.Set                          as S import Data.Either                            (partitionEithers) import Control.Exception                      ( assert, bracket_ )-import Control.Monad                          ( forM, liftM, liftM2, unless, when )+import Control.Monad                          ( forM, mapM, mapM_ ) import Data.Bits                              ( shiftL, shiftR, xor )-import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef ) import Data.List                              ( delete-                                              , foldl'-                                              , intersperse-                                              , isPrefixOf                                               , groupBy ) import Data.Maybe                             ( fromJust )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid                            ( mempty, mappend )-#endif-import Data.Word                              ( Word32 ) import Numeric                                ( showHex ) import System.Directory                       ( canonicalizePath                                               , createDirectory@@ -210,16 +211,16 @@     (globalConfigFile globalFlags)  -- | Return the name of the package index file for this package environment.-tryGetIndexFilePath :: SavedConfig -> IO FilePath-tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)+tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath+tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config)  -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'.-tryGetIndexFilePath' :: GlobalFlags -> IO FilePath-tryGetIndexFilePath' globalFlags = do+tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath+tryGetIndexFilePath' verbosity globalFlags = do   let paths = fromNubList $ globalLocalRepos globalFlags   case paths of-    []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " +++    []  -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++            "no local repos found. " ++ checkConfiguration     _   -> return $ (last paths) </> Index.defaultIndexFileName   where@@ -228,19 +229,19 @@  -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error -- message than just pattern-matching.-getSandboxPackageDB :: ConfigFlags -> IO PackageDB-getSandboxPackageDB configFlags = do+getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB+getSandboxPackageDB verbosity configFlags = do   case configPackageDBs configFlags of     [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB     -- TODO: should we allow multiple package DBs (e.g. with 'inherit')?      []                                     ->-      die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt+      die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt     [_]                                    ->-      die $ "Unexpected contents of the 'package-db' field. "+      die' verbosity $ "Unexpected contents of the 'package-db' field. "             ++ sandboxConfigCorrupt     _                                      ->-      die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt+      die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt    where     sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."@@ -248,11 +249,11 @@  -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags-                                 -> Compiler -> ProgramConfiguration+                                 -> Compiler -> ProgramDb                                  -> IO InstalledPackageIndex-getInstalledPackagesInSandbox verbosity configFlags comp conf = do-    sandboxDB <- getSandboxPackageDB configFlags-    getPackageDBContents verbosity comp sandboxDB conf+getInstalledPackagesInSandbox verbosity configFlags comp progdb = do+    sandboxDB <- getSandboxPackageDB verbosity configFlags+    getPackageDBContents verbosity comp sandboxDB progdb  -- | Temporarily add $SANDBOX_DIR/bin to $PATH. withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a@@ -280,13 +281,13 @@  -- | Initialise a package DB for this compiler if it doesn't exist. initPackageDBIfNeeded :: Verbosity -> ConfigFlags-                         -> Compiler -> ProgramConfiguration+                         -> Compiler -> ProgramDb                          -> IO ()-initPackageDBIfNeeded verbosity configFlags comp conf = do-  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags+initPackageDBIfNeeded verbosity configFlags comp progdb = do+  SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags   packageDBExists <- doesDirectoryExist dbPath   unless packageDBExists $-    Register.initPackageDB verbosity comp conf dbPath+    Register.initPackageDB verbosity comp progdb dbPath   when packageDBExists $     debug verbosity $ "The package database already exists: " ++ dbPath @@ -318,7 +319,7 @@    -- Determine which compiler to use (using the value from ~/.cabal/config).   userConfig <- loadConfig verbosity (globalConfigFile globalFlags)-  (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)+  (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig)    -- Create the package environment file.   pkgEnvFile <- getSandboxConfigFilePath globalFlags@@ -328,7 +329,7 @@       configFlags = savedConfigureFlags config    -- Create the index file if it doesn't exist.-  indexFile <- tryGetIndexFilePath config+  indexFile <- tryGetIndexFilePath verbosity config   indexFileExists <- doesFileExist indexFile   if indexFileExists     then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir@@ -336,7 +337,7 @@   Index.createEmpty verbosity indexFile    -- Create the package DB for the default compiler.-  initPackageDBIfNeeded verbosity configFlags comp conf+  initPackageDBIfNeeded verbosity configFlags comp progdb   maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile     (compilerId comp) platform @@ -367,7 +368,7 @@                                         curDir </> defaultSandboxLocation        when isNonDefaultSandboxLocation $-        die $ "Non-default sandbox location used: '" ++ sandboxDir+        die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir         ++ "'.\nAssuming a shared sandbox. Please delete '"         ++ sandboxDir ++ "' manually." @@ -399,7 +400,7 @@                -> IO () doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do   let savedConfig       = pkgEnvSavedConfig pkgEnv-  indexFile            <- tryGetIndexFilePath savedConfig+  indexFile            <- tryGetIndexFilePath verbosity savedConfig    -- If we're running 'sandbox add-source' for the first time for this compiler,   -- we need to create an initial timestamp record.@@ -407,7 +408,7 @@   maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile     (compilerId comp) platform -  withAddTimestamps sandboxDir $ do+  withAddTimestamps verbosity sandboxDir $ do     -- Path canonicalisation is done in addBuildTreeRefs, but we do it     -- twice because of the timestamps file.     buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs@@ -440,7 +441,7 @@   pkgs      <- forM buildTreeRefs $ \buildTreeRef ->     inDir (Just buildTreeRef) $     return . flattenPackageDescription-            =<< readPackageDescription verbosity+            =<< readGenericPackageDescription verbosity             =<< defaultPackageDesc     verbosity    -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If@@ -474,7 +475,7 @@                        -> IO () sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do   (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)+  indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)    (results, convDict) <-     Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs@@ -483,7 +484,7 @@       removedRefs = fmap convDict removedPaths    unless (null removedPaths) $ do-    removeTimestamps sandboxDir removedPaths+    removeTimestamps verbosity sandboxDir removedPaths      notice verbosity $ "Success deleting sources: " ++       showL removedRefs ++ "\n\n"@@ -491,7 +492,7 @@   unless (null failedPaths) $ do     let groupedFailures = groupBy errorType failedPaths     mapM_ handleErrors groupedFailures-    die $ "The sources with the above errors were skipped. (" +++    die' verbosity $ "The sources with the above errors were skipped. (" ++       showL (fmap getPath failedPaths) ++ ")"    notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++@@ -529,7 +530,7 @@                       -> IO () sandboxListSources verbosity _sandboxFlags globalFlags = do   (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)+  indexFile            <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv)    refs <- Index.listBuildTreeRefs verbosity           Index.ListIgnored Index.LinksAndSnapshots indexFile@@ -551,10 +552,10 @@   let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv   -- Invoke hc-pkg for the most recently configured compiler (if any),   -- using the right package-db for the compiler (see #1935).-  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags+  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags   let dir         = sandboxPackageDBPath sandboxDir comp platform       dbStack     = [GlobalPackageDB, SpecificPackageDB dir]-  Register.invokeHcPkg verbosity comp conf dbStack extraArgs+  Register.invokeHcPkg verbosity comp progdb dbStack extraArgs  updateInstallDirs :: Flag Bool                   -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)@@ -596,7 +597,7 @@     -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.     SandboxPackageEnvironment -> do       (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags-                              -- ^ Prints an error message and exits on error.+                              -- Prints an error message and exits on error.       let config = pkgEnvSavedConfig pkgEnv       return (UseSandbox sandboxDir, config) @@ -635,7 +636,7 @@         flag = (globalRequireSandbox . savedGlobalFlags $ config)                `mappend` (globalRequireSandbox globalFlags)         checkFlag (Flag True)  =-          die $ "'require-sandbox' is set to True, but no sandbox is present. "+          die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. "              ++ "Use '--no-require-sandbox' if you want to override "              ++ "'require-sandbox' temporarily."         checkFlag (Flag False) = return ()@@ -673,37 +674,37 @@                             { configDistPref  = Flag sandboxDistPref }       haddockFlags        = mempty                             { haddockDistPref = Flag sandboxDistPref }-  (comp, platform, conf) <- configCompilerAux' configFlags-  retVal                 <- newIORef NoDepsReinstalled+  (comp, platform, progdb) <- configCompilerAux' configFlags+  retVal                   <- newIORef NoDepsReinstalled    withSandboxPackageInfo verbosity configFlags globalFlags-                         comp platform conf sandboxDir $ \sandboxPkgInfo ->+                         comp platform progdb sandboxDir $ \sandboxPkgInfo ->     unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do -     withRepoContext verbosity globalFlags $ \repoContext -> do-      let args :: InstallArgs-          args = ((configPackageDB' configFlags)-                 ,repoContext-                 ,comp, platform, conf-                 ,UseSandbox sandboxDir, Just sandboxPkgInfo-                 ,globalFlags, configFlags, configExFlags, installFlags-                 ,haddockFlags)+      withRepoContext verbosity globalFlags $ \repoContext -> do+        let args :: InstallArgs+            args = ((configPackageDB' configFlags)+                  ,repoContext+                  ,comp, platform, progdb+                  ,UseSandbox sandboxDir, Just sandboxPkgInfo+                  ,globalFlags, configFlags, configExFlags, installFlags+                  ,haddockFlags) -      -- This can actually be replaced by a call to 'install', but we use a-      -- lower-level API because of layer separation reasons. Additionally, we-      -- might want to use some lower-level features this in the future.-      withSandboxBinDirOnSearchPath sandboxDir $ do-        installContext <- makeInstallContext verbosity args Nothing-        installPlan    <- foldProgress logMsg die' return =<<-                          makeInstallPlan verbosity args installContext+        -- This can actually be replaced by a call to 'install', but we use a+        -- lower-level API because of layer separation reasons. Additionally, we+        -- might want to use some lower-level features this in the future.+        withSandboxBinDirOnSearchPath sandboxDir $ do+          installContext <- makeInstallContext verbosity args Nothing+          installPlan    <- foldProgress logMsg die'' return =<<+                            makeInstallPlan verbosity args installContext -        processInstallPlan verbosity args installContext installPlan-        writeIORef retVal ReinstalledSomeDeps+          processInstallPlan verbosity args installContext installPlan+          writeIORef retVal ReinstalledSomeDeps    readIORef retVal      where-      die' message = die (message ++ installFailedInSandbox)+      die'' message = die' verbosity (message ++ installFailedInSandbox)       -- TODO: use a better error message, remove duplication.       installFailedInSandbox =         "Note: when using a sandbox, all packages are required to have "@@ -721,25 +722,25 @@ -- we don't update the timestamp file here - this is done in -- 'postInstallActions'. withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                          -> Compiler -> Platform -> ProgramConfiguration+                          -> Compiler -> Platform -> ProgramDb                           -> FilePath                           -> (SandboxPackageInfo -> IO ())                           -> IO () withSandboxPackageInfo verbosity configFlags globalFlags-                       comp platform conf sandboxDir cont = do+                       comp platform progdb sandboxDir cont = do   -- List all add-source deps.-  indexFile              <- tryGetIndexFilePath' globalFlags+  indexFile              <- tryGetIndexFilePath' verbosity globalFlags   buildTreeRefs          <- Index.listBuildTreeRefs verbosity                             Index.DontListIgnored Index.OnlyLinks indexFile   let allAddSourceDepsSet = S.fromList buildTreeRefs    -- List all packages installed in the sandbox.   installedPkgIndex <- getInstalledPackagesInSandbox verbosity-                       configFlags comp conf+                       configFlags comp progdb   let err = "Error reading sandbox package information."   -- Get the package descriptions for all add-source deps.-  depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs-  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles+  depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs+  depsPkgDescs   <- mapM (readGenericPackageDescription verbosity) depsCabalFiles   let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)       isInstalled pkgid = not . null         . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid@@ -775,17 +776,17 @@ -- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the -- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags-                               -> Compiler -> Platform -> ProgramConfiguration+                               -> Compiler -> Platform -> ProgramDb                                -> UseSandbox                                -> (Maybe SandboxPackageInfo -> IO ())                                -> IO () maybeWithSandboxPackageInfo verbosity configFlags globalFlags-                            comp platform conf useSandbox cont =+                            comp platform progdb useSandbox cont =   case useSandbox of     NoSandbox             -> cont Nothing     UseSandbox sandboxDir -> withSandboxPackageInfo verbosity                              configFlags globalFlags-                             comp platform conf sandboxDir+                             comp platform progdb sandboxDir                              (\spi -> cont (Just spi))  -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that@@ -853,28 +854,12 @@ -- -- Utils (transitionary) ----- FIXME: configPackageDB' and configCompilerAux' don't really belong in this--- module--- -configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-    interpretPackageDbFlags userInstall (configPackageDBs cfg)-  where-    userInstall = fromFlagOrDefault True (configUserInstall cfg)--configCompilerAux' :: ConfigFlags-                   -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerAux' configFlags =-  configCompilerAuxEx configFlags-    --FIXME: make configCompilerAux use a sensible verbosity-    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }- -- | 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, ProgramConfiguration)+                           -> IO (Compiler, Platform, ProgramDb) getPersistOrConfigCompiler configFlags = do   distPref <- findDistPrefOrDefault (configDistPref configFlags)   mlbi <- maybeGetPersistBuildConfig distPref
Distribution/Client/Sandbox/Index.hs view
@@ -34,7 +34,7 @@                                  , makeAbsoluteToCwd, tryCanonicalizePath                                  , tryFindAddSourcePackageDesc  ) -import Distribution.Simple.Utils ( die, debug )+import Distribution.Simple.Utils ( die', debug ) import Distribution.Compat.Exception   ( tryIO ) import Distribution.Verbosity    ( Verbosity ) @@ -61,12 +61,12 @@ defaultIndexFileName = "00-index.tar"  -- | Given a path, ensure that it refers to a local build tree.-buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef)-buildTreeRefFromPath refType dir = do+buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef)+buildTreeRefFromPath verbosity refType dir = do   dirExists <- doesDirectoryExist dir   unless dirExists $-    die $ "directory '" ++ dir ++ "' does not exist"-  _ <- tryFindAddSourcePackageDesc dir "Error adding source reference."+    die' verbosity $ "directory '" ++ dir ++ "' does not exist"+  _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference."   return . Just $ BuildTreeRef refType dir  -- | Given a tar archive entry, try to parse it as a local build tree reference.@@ -120,14 +120,14 @@  -- | Check that the provided path is either an existing directory, or a tar -- archive in an existing directory.-validateIndexPath :: FilePath -> IO FilePath-validateIndexPath path' = do+validateIndexPath :: Verbosity -> FilePath -> IO FilePath+validateIndexPath verbosity path' = do    path <- makeAbsoluteToCwd path'    if (== ".tar") . takeExtension $ path      then return path      else do dirExists <- doesDirectoryExist path              unless dirExists $-               die $ "directory does not exist: '" ++ path ++ "'"+               die' verbosity $ "directory does not exist: '" ++ path ++ "'"              return $ path </> defaultIndexFileName  -- | Create an empty index file.@@ -149,11 +149,11 @@ addBuildTreeRefs _         _   []  _ =   error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" addBuildTreeRefs verbosity path l' refType = do-  checkIndexExists path+  checkIndexExists verbosity path   l <- liftM nub . mapM tryCanonicalizePath $ l'   treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path)   -- Add only those paths that aren't already in the index.-  treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)+  treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex)   let entries = map writeBuildTreeRef (catMaybes treesToAdd)   unless (null entries) $ do     withBinaryFile path ReadWriteMode $ \h -> do@@ -176,7 +176,7 @@ removeBuildTreeRefs _         _   [] =   error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" removeBuildTreeRefs verbosity indexPath l = do-  checkIndexExists indexPath+  checkIndexExists verbosity indexPath   let tmpFile = indexPath <.> "tmp"    canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr@@ -240,7 +240,7 @@                      -> FilePath                      -> IO [FilePath] listBuildTreeRefs verbosity listIgnored refTypesToList path = do-  checkIndexExists path+  checkIndexExists verbosity path   buildTreeRefs <-     case listIgnored of       DontListIgnored -> do@@ -274,8 +274,8 @@   -- | Check that the package index file exists and exit with error if it does not.-checkIndexExists :: FilePath -> IO ()-checkIndexExists path = do+checkIndexExists :: Verbosity -> FilePath -> IO ()+checkIndexExists verbosity path = do   indexExists <- doesFileExist path   unless indexExists $-    die $ "index does not exist: '" ++ path ++ "'"+    die' verbosity $ "index does not exist: '" ++ path ++ "'"
Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -36,12 +36,12 @@                                        , installDirsFields, withProgramsFields                                        , withProgramOptionsFields                                        , defaultCompiler )-import Distribution.Client.Dependency.Types ( ConstraintSource (..) ) import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)                                        , InstallFlags(..)                                        , defaultSandboxLocation )-import Distribution.Utils.NubList            ( toNubList )+import Distribution.Client.Targets     ( userConstraintPackageName )+import Distribution.Utils.NubList      ( toNubList ) import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)                                        , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate@@ -50,7 +50,8 @@ import Distribution.Simple.Setup       ( Flag(..)                                        , ConfigFlags(..), HaddockFlags(..)                                        , fromFlagOrDefault, toFlag, flagToMaybe )-import Distribution.Simple.Utils       ( die, info, notice, warn )+import Distribution.Simple.Utils       ( die', info, notice, warn, debug )+import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)                                        , commaListField, commaNewLineListField                                        , liftField, lineNo, locatedErrorMsg@@ -60,8 +61,9 @@ import Distribution.System             ( Platform ) import Distribution.Verbosity          ( Verbosity, normal ) import Control.Monad                   ( foldM, liftM2, when, unless )-import Data.List                       ( partition )+import Data.List                       ( partition, sortBy ) import Data.Maybe                      ( isJust )+import Data.Ord                        ( comparing ) import Distribution.Compat.Exception   ( catchIO ) import Distribution.Compat.Semigroup import System.Directory                ( doesDirectoryExist, doesFileExist@@ -275,14 +277,24 @@  -- | 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 -> FilePath -> Maybe FilePath+                       -> IO PackageEnvironment userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do     let path = pkgEnvDir </> userPackageEnvironmentFile-    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) mempty path+    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)+            mempty path     case (minp, globalConfigLocation) of       (Just parseRes, _)  -> processConfigParse path parseRes-      (_, Just globalLoc) -> maybe (warn verbosity ("no constraints file found at " ++ globalLoc) >> return mempty) (processConfigParse globalLoc) =<< readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) mempty globalLoc-      _ -> return mempty+      (_, 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       when (not $ null warns) $ warn verbosity $@@ -297,7 +309,8 @@ -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig loadUserConfig verbosity pkgEnvDir globalConfigLocation =-    fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation+    fmap pkgEnvSavedConfig $+    userPackageEnvironment verbosity pkgEnvDir globalConfigLocation  -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'.@@ -306,7 +319,7 @@                      -> IO PackageEnvironment handleParseResult verbosity path minp =   case minp of-    Nothing -> die $+    Nothing -> die' verbosity $       "The package environment file '" ++ path ++ "' doesn't exist"     Just (ParseOk warns parseResult) -> do       when (not $ null warns) $ warn verbosity $@@ -314,7 +327,7 @@       return parseResult     Just (ParseFailed err) -> do       let (line, msg) = locatedErrorMsg err-      die $ "Error parsing package environment file " ++ path+      die' verbosity $ "Error parsing package environment file " ++ path         ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg  -- | Try to load the given package environment file, exiting with error if it@@ -339,7 +352,7 @@   dirExists            <- doesDirectoryExist sandboxDir   -- TODO: Also check for an initialised package DB?   unless dirExists $-    die ("No sandbox exists at " ++ sandboxDir)+    die' verbosity ("No sandbox exists at " ++ sandboxDir)   info verbosity $ "Using a sandbox located at " ++ sandboxDir    let base   = basePackageEnvironment@@ -399,7 +412,8 @@    , commaNewLineListField "constraints"     (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)-    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)+    (sortConstraints . configExConstraints+     . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configExConstraints = v })) @@ -433,6 +447,8 @@                                  $ pkgEnv          }       }++    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)  -- | Read the package environment file. readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
Distribution/Client/Sandbox/Timestamp.hs view
@@ -29,7 +29,7 @@ import qualified Data.Map as M  import Distribution.Compiler                         (CompilerId)-import Distribution.Simple.Utils                     (debug, die, warn)+import Distribution.Simple.Utils                     (debug, die', warn) import Distribution.System                           (Platform) import Distribution.Text                             (display) import Distribution.Verbosity                        (Verbosity)@@ -38,9 +38,10 @@ import Distribution.Client.Sandbox.Index   (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)   ,listBuildTreeRefs)+import Distribution.Client.SetupWrapper  import Distribution.Compat.Exception                 (catchIO)-import Distribution.Client.Compat.Time               (ModTime, getCurTime,+import Distribution.Compat.Time               (ModTime, getCurTime,                                                       getModTime,                                                       posixSecondsToModTime) @@ -66,8 +67,8 @@  -- | Read the timestamp file. Exits with error if the timestamp file is -- corrupted. Returns an empty list if the file doesn't exist.-readTimestampFile :: FilePath -> IO [TimestampFileRecord]-readTimestampFile timestampFile = do+readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord]+readTimestampFile verbosity timestampFile = do   timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"   case reads timestampString of     [(version, s)]@@ -90,8 +91,8 @@         _ -> dieCorrupted     _ -> dieCorrupted   where-    dieWrongFormat    = die $ wrongFormat ++ deleteAndRecreate-    dieCorrupted      = die $ corrupted ++ deleteAndRecreate+    dieWrongFormat    = die' verbosity $ wrongFormat ++ deleteAndRecreate+    dieCorrupted      = die' verbosity $ corrupted ++ deleteAndRecreate     wrongFormat       = "The timestamps file is in the wrong format."     corrupted         = "The timestamps file is corrupted."     deleteAndRecreate = " Please delete and recreate the sandbox."@@ -106,12 +107,12 @@     timestampTmpFile = timestampFile <.> "tmp"  -- | Read, process and write the timestamp file in one go.-withTimestampFile :: FilePath+withTimestampFile :: Verbosity -> FilePath                      -> ([TimestampFileRecord] -> IO [TimestampFileRecord])                      -> IO ()-withTimestampFile sandboxDir process = do+withTimestampFile verbosity sandboxDir process = do   let timestampFile = sandboxDir </> timestampFileName-  timestampRecords <- readTimestampFile timestampFile >>= process+  timestampRecords <- readTimestampFile verbosity timestampFile >>= process   writeTimestampFile timestampFile timestampRecords  -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps@@ -155,7 +156,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile                                 compId platform = do   let key = timestampRecordKey compId platform-  withTimestampFile sandboxDir $ \timestampRecords -> do+  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do     case lookup key timestampRecords of       Just _  -> return timestampRecords       Nothing -> do@@ -167,21 +168,21 @@  -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers).-withAddTimestamps :: FilePath -> IO [FilePath] -> IO ()-withAddTimestamps sandboxDir act = do+withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO ()+withAddTimestamps verbosity sandboxDir act = do   let initialTimestamp = minBound-  withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act+  withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act  -- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers).-removeTimestamps :: FilePath -> [FilePath] -> IO ()-removeTimestamps idxFile =-  withActionOnAllTimestamps removeTimestamps' idxFile . return+removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO ()+removeTimestamps verbosity idxFile =+  withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return  -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the -- given compiler & platform).-withUpdateTimestamps :: FilePath -> CompilerId -> Platform+withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform                         ->([AddSourceTimestamp] -> IO [FilePath])                         -> IO () withUpdateTimestamps =@@ -193,11 +194,12 @@ -- updates the timestamp file. The IO action is run only once. withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]                               -> [AddSourceTimestamp])+                             -> Verbosity                              -> FilePath                              -> IO [FilePath]                              -> IO ()-withActionOnAllTimestamps f sandboxDir act =-  withTimestampFile sandboxDir $ \timestampRecords -> do+withActionOnAllTimestamps f verbosity sandboxDir act =+  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do     paths <- act     return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] @@ -207,14 +209,15 @@ withActionOnCompilerTimestamps :: ([AddSourceTimestamp]                                    -> [FilePath] -> ModTime                                    -> [AddSourceTimestamp])+                                  -> Verbosity                                   -> FilePath                                   -> CompilerId                                   -> Platform                                   -> ([AddSourceTimestamp] -> IO [FilePath])                                   -> IO ()-withActionOnCompilerTimestamps f sandboxDir compId platform act = do+withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do   let needle = timestampRecordKey compId platform-  withTimestampFile sandboxDir $ \timestampRecords -> do+  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do     timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->       if key == needle       then do paths <- act timestamps@@ -227,7 +230,9 @@ isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool isDepModified verbosity now (packageDir, timestamp) = do   debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)-  depSources <- allPackageSourceFiles verbosity packageDir+  -- TODO: we should properly plumb the correct options through+  -- instead of using defaultSetupScriptOptions+  depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir   go depSources    where@@ -252,7 +257,7 @@                        -- ^ The set of all installed add-source deps.                     -> IO [FilePath] listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do-  timestampRecords <- readTimestampFile (sandboxDir </> timestampFileName)+  timestampRecords <- readTimestampFile verbosity (sandboxDir </> timestampFileName)   let needle        = timestampRecordKey compId platform   timestamps       <- maybe noTimestampRecord return                       (lookup needle timestampRecords)@@ -262,7 +267,7 @@     $ timestamps    where-    noTimestampRecord = die $ "Сouldn't find a timestamp record for the given "+    noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given "                         ++ "compiler/platform pair. "                         ++ "Please report this on the Cabal bug tracker: "                         ++ "https://github.com/haskell/cabal/issues/new ."
Distribution/Client/Sandbox/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.Types@@ -13,13 +12,12 @@   SandboxPackageInfo(..)   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import Distribution.Client.Types (SourcePackage)-import Distribution.Compat.Semigroup (Semigroup((<>)))+import Distribution.Client.Types (UnresolvedSourcePackage) -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif import qualified Data.Set as S  -- | Are we using a sandbox?@@ -49,11 +47,11 @@ -- | Data about the packages installed in the sandbox that is passed from -- 'reinstallAddSourceDeps' to the solver. data SandboxPackageInfo = SandboxPackageInfo {-  modifiedAddSourceDependencies :: ![SourcePackage],+  modifiedAddSourceDependencies :: ![UnresolvedSourcePackage],   -- ^ Modified add-source deps that we want to reinstall. These are guaranteed   -- to be already installed in the sandbox. -  otherAddSourceDependencies    :: ![SourcePackage],+  otherAddSourceDependencies    :: ![UnresolvedSourcePackage],   -- ^ Remaining add-source deps. Some of these may be not installed in the   -- sandbox.
+ Distribution/Client/SavedFlags.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Distribution.Client.SavedFlags+       ( readCommandFlags, writeCommandFlags+       , readSavedArgs, writeSavedArgs+       ) where++import Distribution.Simple.Command+import Distribution.Simple.UserHooks ( Args )+import Distribution.Simple.Utils+       ( createDirectoryIfMissingVerbose, unintersperse )+import Distribution.Verbosity++import Control.Exception ( Exception, throwIO )+import Control.Monad ( liftM )+import Data.List ( intercalate )+import Data.Maybe ( fromMaybe )+import Data.Typeable+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 liftM (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 <- liftM (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 view
@@ -0,0 +1,146 @@+module Distribution.Client.Security.DNS+    ( queryBootstrapMirrors+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Monad+import Control.DeepSeq (force)+import Control.Exception (SomeException, evaluate, try)+import Network.URI (URI(..), URIAuth(..), parseURI)++import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Simple.Program.Db+         ( emptyProgramDb, addKnownProgram+         , configureAllKnownPrograms, lookupProgram )+import Distribution.Simple.Program+         ( simpleProgram+         , programInvocation+         , getProgramInvocationOutput )+import Distribution.Compat.Exception (displayException)++-- | 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]+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 ++ " :")+                      forM_ 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]+                    ]++    isUrlBase :: String -> Maybe Int+    isUrlBase s+      | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns+      | otherwise = Nothing+      where+        ns = take (length s - 8) s++-- | 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++-- | 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/Setup.hs view
@@ -18,10 +18,11 @@     ( globalCommand, GlobalFlags(..), defaultGlobalFlags     , RepoContext(..), withRepoContext     , configureCommand, ConfigFlags(..), filterConfigureFlags+    , configPackageDB', configCompilerAux'     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags-                        , configureExOptions     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)     , replCommand, testCommand, benchmarkCommand+                        , configureExOptions, reconfigureCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , defaultSolver, defaultMaxBackjumps     , listCommand, ListFlags(..)@@ -32,10 +33,11 @@     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)     , genBoundsCommand+    , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..)     , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , formatCommand-    , uploadCommand, UploadFlags(..)+    , uploadCommand, UploadFlags(..), IsCandidate(..)     , reportCommand, ReportFlags(..)     , runCommand     , initCommand, IT.InitFlags(..)@@ -47,6 +49,7 @@     , userConfigCommand, UserConfigFlags(..)     , manpageCommand +    , applyFlagDefaults     , parsePackageArgs     --TODO: stop exporting these:     , showRepo@@ -54,12 +57,17 @@     , readRepo     ) where +import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+ import Distribution.Client.Types          ( Username(..), Password(..), RemoteRepo(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), ConstraintSource(..) )+         ( PreSolver(..) )+import Distribution.Client.IndexUtils.Timestamp+         ( IndexState ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets@@ -67,40 +75,46 @@ import Distribution.Utils.NubList          ( NubList, toNubList, fromNubList) +import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.Settings -import Distribution.Simple.Compiler (PackageDB)-import Distribution.Simple.Program-         ( defaultProgramConfiguration )+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 ( computeEffectiveProfiling )+import Distribution.Simple.Configure+       ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup          ( ConfigFlags(..), BuildFlags(..), ReplFlags          , TestFlags(..), BenchmarkFlags(..)          , SDistFlags(..), HaddockFlags(..)          , readPackageDbList, showPackageDbList-         , Flag(..), toFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg-         , readPToMaybe, optionNumJobs )+         , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag+         , BooleanFlag(..), optionVerbosity+         , boolOpt, boolOpt', trueArg, falseArg+         , optionNumJobs ) import Distribution.Simple.InstallDirs-         ( PathTemplate, InstallDirs(dynlibdir, sysconfdir)-         , toPathTemplate, fromPathTemplate )+         ( PathTemplate, InstallDirs(..)+         , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version-         ( Version(Version), anyVersion, thisVersion )+         ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+         ( PackageIdentifier, PackageName, packageName, packageVersion )+import Distribution.Types.Dependency import Distribution.PackageDescription          ( BuildType(..), RepoKind(..) )+import Distribution.System ( Platform ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, char, munch1, pfail,  (+++) )-import Distribution.Compat.Semigroup+         ( ReadP, char, munch1, pfail, sepBy1, (+++) )+import Distribution.ParseUtils+         ( readPToMaybe ) import Distribution.Verbosity-         ( Verbosity, normal )+         ( Verbosity, lessVerbose, normal, verboseNoFlags ) import Distribution.Simple.Utils          ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags@@ -108,21 +122,22 @@          , RepoContext(..), withRepoContext          ) -import Data.Char-         ( isAlphaNum ) import Data.List-         ( intercalate, deleteFirstsBy )-import Data.Maybe-         ( maybeToList, fromMaybe )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)-import Control.Monad-         ( liftM )+         ( deleteFirstsBy ) import System.FilePath          ( (</>) ) import Network.URI          ( parseAbsoluteURI, uriToString ) +applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+                  -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) =+  ( commandDefaultFlags configureCommand <> configFlags+  , defaultConfigExFlags <> configExFlags+  , defaultInstallFlags <> installFlags+  , Cabal.defaultHaddockFlags <> haddockFlags+  )+ globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI {     commandName         = "",@@ -153,6 +168,7 @@           , "get"           , "init"           , "configure"+          , "reconfigure"           , "build"           , "clean"           , "run"@@ -165,12 +181,22 @@           , "report"           , "freeze"           , "gen-bounds"+          , "outdated"+          , "doctest"           , "haddock"           , "hscolour"           , "copy"           , "register"           , "sandbox"           , "exec"+          , "new-build"+          , "new-configure"+          , "new-repl"+          , "new-freeze"+          , "new-run"+          , "new-test"+          , "new-bench"+          , "new-haddock"           ]         maxlen    = maximum $ [length name | (name, _) <- cmdDescs]         align str = str ++ replicate (maxlen - length str) ' '@@ -216,15 +242,28 @@         , par         , addCmd "freeze"         , addCmd "gen-bounds"+        , addCmd "outdated"+        , addCmd "doctest"         , addCmd "haddock"         , addCmd "hscolour"         , addCmd "copy"         , addCmd "register"+        , addCmd "reconfigure"         , par         , startGroup "sandbox"         , addCmd "sandbox"         , addCmd "exec"         , addCmdCustom "repl" "Open interpreter with access to sandbox packages."+        , par+        , startGroup "new-style projects (beta)"+        , addCmd "new-build"+        , addCmd "new-configure"+        , addCmd "new-repl"+        , addCmd "new-run"+        , addCmd "new-test"+        , addCmd "new-bench"+        , addCmd "new-freeze"+        , addCmd "new-haddock"         ] ++ if null otherCmds then [] else par                                            :startGroup "other"                                            :[addCmd n | n <- otherCmds])@@ -294,6 +333,10 @@          "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@@ -343,74 +386,100 @@        ++ "    with some package-specific flag.\n"   }  where-  c = Cabal.configureCommand defaultProgramConfiguration+  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-  | cabalLibVersion >= Version [1,24,1] [] = flags_latest-  -- ^ NB: we expect the latest version to be the most common case.-  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10-  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0-  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0-  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0-  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0-  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0-  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1-  | cabalLibVersion <  Version [1,21,1] [] = flags_1_20_0-  | cabalLibVersion <  Version [1,22,0] [] = flags_1_21_0-  | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0-  | cabalLibVersion <  Version [1,24,1] [] = flags_1_24_0+  -- NB: we expect the latest version to be the most common case,+  -- so test it first.+  | cabalLibVersion >= mkVersion [1,25,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,23,0] = flags_1_23_0+  | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0   | otherwise = flags_latest   where-    (profEnabledLib, profEnabledExe) = computeEffectiveProfiling flags     flags_latest = flags        {       -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.       configConstraints = [],-      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use+      -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use       -- '--exact-configuration' instead.-      configAllowNewer  = Just Cabal.AllowNewerNone+      configAllowOlder  = Just (Cabal.AllowOlder Cabal.RelaxDepsNone),+      configAllowNewer  = Just (Cabal.AllowNewer Cabal.RelaxDepsNone)       } -    -- Cabal < 1.24.1 doesn't know about --dynlibdir.-    flags_1_24_0 = flags_latest { configInstallDirs = configInstallDirs_1_24_0}-    configInstallDirs_1_24_0 = (configInstallDirs flags) { dynlibdir = NoFlag }-+    flags_1_25_0 = flags_latest {+      -- 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_latest),+      -- 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.-    flags_1_22_0 = flags_1_24_0 { configProfDetail    = NoFlag+    (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags+    flags_1_23_0 = flags_1_25_0 { configProfDetail    = NoFlag                                 , configProfLibDetail = NoFlag                                 , configIPID          = NoFlag                                 , configProf          = NoFlag-                                , configProfExe       = Flag profEnabledExe-                                , configProfLib       = Flag profEnabledLib+                                , configProfExe       = Flag tryExeProfiling+                                , configProfLib       = Flag tryLibProfiling                                 }      -- Cabal < 1.22 doesn't know about '--disable-debug-info'.-    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }+    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_22_0)-    flags_1_20_0 =-      flags_1_21_0 { configRelocatable = NoFlag+    -- (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_1 = flags_1_20_0 { configExactConfiguration = NoFlag+    flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag                                 , configStripLibs = NoFlag }     -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.-    flags_1_19_0 = flags_1_19_1 { configDependencies = []+    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_0 { configProgramPathExtra = toNubList []+    flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList []                                 , configInstallDirs = configInstallDirs_1_18_0}-    configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_0) { sysconfdir = NoFlag }+    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'@@ -422,6 +491,21 @@     -- 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 -- ------------------------------------------------------------@@ -490,6 +574,28 @@ 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 ++ " configure'. "+         ++ "If the package has never been configured, the default flags are "+         ++ "used."+    , commandNotes        = Just $ \pname ->+        "Examples:\n"+        ++ "  " ++ pname ++ " reconfigure\n"+        ++ "    Configure with the most recently used flags.\n"+        ++ "  " ++ pname ++ " reconfigure -w PATH\n"+        ++ "    Reconfigure with the most recently used flags,\n"+        ++ "    but use the compiler at PATH.\n\n"+    , commandUsage        = usageAlternatives "reconfigure" [ "[FLAGS]" ]+    , commandDefaultFlags = mempty+    }+ -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------@@ -524,7 +630,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.buildCommand defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramDb  instance Monoid BuildExFlags where   mempty = gmempty@@ -550,7 +656,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.replCommand defaultProgramConfiguration+    parent = Cabal.replCommand defaultProgramDb  -- ------------------------------------------------------------ -- * Test command@@ -565,7 +671,7 @@                         (commandOptions parent showOrParseArgs)                         ++                         liftOptions get2 set2-                        (Cabal.buildOptions progConf showOrParseArgs)+                        (Cabal.buildOptions progDb showOrParseArgs)                         ++                         liftOptions get3 set3 (buildExOptions showOrParseArgs)   }@@ -574,8 +680,8 @@     get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)     get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent   = Cabal.testCommand-    progConf = defaultProgramConfiguration+    parent = Cabal.testCommand+    progDb = defaultProgramDb  -- ------------------------------------------------------------ -- * Bench command@@ -590,7 +696,7 @@                         (commandOptions parent showOrParseArgs)                         ++                         liftOptions get2 set2-                        (Cabal.buildOptions progConf showOrParseArgs)+                        (Cabal.buildOptions progDb showOrParseArgs)                         ++                         liftOptions get3 set3 (buildExOptions showOrParseArgs)   }@@ -599,8 +705,8 @@     get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)     get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent   = Cabal.benchmarkCommand-    progConf = defaultProgramConfiguration+    parent = Cabal.benchmarkCommand+    progDb = defaultProgramDb  -- ------------------------------------------------------------ -- * Fetch command@@ -612,10 +718,12 @@       fetchDryRun    :: Flag Bool,       fetchSolver           :: Flag PreSolver,       fetchMaxBackjumps     :: Flag Int,-      fetchReorderGoals     :: Flag Bool,-      fetchIndependentGoals :: Flag Bool,-      fetchShadowPkgs       :: Flag Bool,-      fetchStrongFlags      :: Flag Bool,+      fetchReorderGoals     :: Flag ReorderGoals,+      fetchCountConflicts   :: Flag CountConflicts,+      fetchIndependentGoals :: Flag IndependentGoals,+      fetchShadowPkgs       :: Flag ShadowPkgs,+      fetchStrongFlags      :: Flag StrongFlags,+      fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls,       fetchVerbosity :: Flag Verbosity     } @@ -626,10 +734,12 @@     fetchDryRun    = toFlag False,     fetchSolver           = Flag defaultSolver,     fetchMaxBackjumps     = Flag defaultMaxBackjumps,-    fetchReorderGoals     = Flag False,-    fetchIndependentGoals = Flag False,-    fetchShadowPkgs       = Flag False,-    fetchStrongFlags      = Flag False,+    fetchReorderGoals     = Flag (ReorderGoals False),+    fetchCountConflicts   = Flag (CountConflicts True),+    fetchIndependentGoals = Flag (IndependentGoals False),+    fetchShadowPkgs       = Flag (ShadowPkgs False),+    fetchStrongFlags      = Flag (StrongFlags False),+    fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False),     fetchVerbosity = toFlag normal    } @@ -673,9 +783,11 @@        optionSolverFlags showOrParseArgs                          fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })+                         fetchCountConflicts   (\v flags -> flags { fetchCountConflicts   = 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 })    } @@ -689,10 +801,12 @@       freezeBenchmarks       :: Flag Bool,       freezeSolver           :: Flag PreSolver,       freezeMaxBackjumps     :: Flag Int,-      freezeReorderGoals     :: Flag Bool,-      freezeIndependentGoals :: Flag Bool,-      freezeShadowPkgs       :: Flag Bool,-      freezeStrongFlags      :: Flag Bool,+      freezeReorderGoals     :: Flag ReorderGoals,+      freezeCountConflicts   :: Flag CountConflicts,+      freezeIndependentGoals :: Flag IndependentGoals,+      freezeShadowPkgs       :: Flag ShadowPkgs,+      freezeStrongFlags      :: Flag StrongFlags,+      freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls,       freezeVerbosity        :: Flag Verbosity     } @@ -703,10 +817,12 @@     freezeBenchmarks       = toFlag False,     freezeSolver           = Flag defaultSolver,     freezeMaxBackjumps     = Flag defaultMaxBackjumps,-    freezeReorderGoals     = Flag False,-    freezeIndependentGoals = Flag False,-    freezeShadowPkgs       = Flag False,-    freezeStrongFlags      = Flag False,+    freezeReorderGoals     = Flag (ReorderGoals False),+    freezeCountConflicts   = Flag (CountConflicts True),+    freezeIndependentGoals = Flag (IndependentGoals False),+    freezeShadowPkgs       = Flag (ShadowPkgs False),+    freezeStrongFlags      = Flag (StrongFlags False),+    freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False),     freezeVerbosity        = toFlag normal    } @@ -726,7 +842,8 @@     commandUsage        = usageFlags "freeze",     commandDefaultFlags = defaultFreezeFlags,     commandOptions      = \ showOrParseArgs -> [-         optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })+         optionVerbosity freezeVerbosity+         (\v flags -> flags { freezeVerbosity = v })         , option [] ["dry-run"]            "Do not freeze anything, only print what would be frozen"@@ -734,34 +851,44 @@            trueArg         , option [] ["tests"]-           "freezing of the dependencies of any tests suites in the package description file."+           ("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."+           ("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 }) :+       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 })                          freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })                          freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })                          freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })+                         freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = 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"+      ++ "Generated bounds are printed to stdout.  "+      ++ "You can then paste them into your .cabal file.\n"       ++ "\n",     commandNotes        = Nothing,     commandUsage        = usageFlags "gen-bounds",@@ -772,6 +899,116 @@   }  -- ------------------------------------------------------------+-- * '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,+  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,+  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"]+     "Act on the freeze file"+     outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v })+     trueArg++    ,option [] ["new-freeze-file"]+     "Act on the new-style freeze file"+     outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v })+     trueArg++    ,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 display))++   ,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 . display) $ pkgs++    ignoreMajorVersionBumpsParser  =+      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser++    pkgNameListParser = readP_to_E+      ("Couldn't parse the list of package names: " ++)+      (Parse.sepBy1 parse (Parse.char ','))++-- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------ @@ -892,7 +1129,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    parent = Cabal.buildCommand defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramDb  -- ------------------------------------------------------------ -- * Report flags@@ -951,6 +1188,7 @@ data GetFlags = GetFlags {     getDestDir          :: Flag FilePath,     getPristine         :: Flag Bool,+    getIndexState       :: Flag IndexState,     getSourceRepository :: Flag (Maybe RepoKind),     getVerbosity        :: Flag Verbosity   } deriving Generic@@ -959,6 +1197,7 @@ defaultGetFlags = GetFlags {     getDestDir          = mempty,     getPristine         = mempty,+    getIndexState       = mempty,     getSourceRepository = mempty,     getVerbosity        = toFlag normal    }@@ -996,6 +1235,20 @@                                   (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" (readP_to_E (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` parse))+                          (flagToList . fmap display))+        , option [] ["pristine"]            ("Unpack the original pristine tarball, rather than updating the "            ++ ".cabal file with the latest revision from the package archive.")@@ -1150,26 +1403,39 @@     installHaddockIndex     :: Flag PathTemplate,     installDryRun           :: Flag Bool,     installMaxBackjumps     :: Flag Int,-    installReorderGoals     :: Flag Bool,-    installIndependentGoals :: Flag Bool,-    installShadowPkgs       :: Flag Bool,-    installStrongFlags      :: Flag Bool,+    installReorderGoals     :: Flag ReorderGoals,+    installCountConflicts   :: Flag CountConflicts,+    installIndependentGoals :: Flag IndependentGoals,+    installShadowPkgs       :: Flag ShadowPkgs,+    installStrongFlags      :: Flag StrongFlags,+    installAllowBootLibInstalls :: Flag AllowBootLibInstalls,     installReinstall        :: Flag Bool,-    installAvoidReinstalls  :: Flag Bool,+    installAvoidReinstalls  :: Flag AvoidReinstalls,     installOverrideReinstall :: Flag Bool,     installUpgradeDeps      :: Flag Bool,     installOnly             :: Flag Bool,     installOnlyDeps         :: Flag Bool,+    installIndexState       :: Flag IndexState,     installRootCmd          :: Flag String,     installSummaryFile      :: NubList PathTemplate,     installLogFile          :: Flag PathTemplate,     installBuildReports     :: Flag ReportLevel,     installReportPlanningFailure :: Flag Bool,     installSymlinkBinDir    :: Flag FilePath,+    installPerComponent     :: Flag Bool,     installOneShot          :: Flag Bool,     installNumJobs          :: Flag (Maybe Int),+    installKeepGoing        :: Flag Bool,     installRunTests         :: Flag Bool,-    installOfflineMode      :: Flag Bool+    installOfflineMode      :: Flag Bool,+    -- | The cabal project file name; defaults to @cabal.project@.+    -- Th 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.+    installProjectFileName   :: Flag FilePath   }   deriving (Eq, Generic) @@ -1181,26 +1447,32 @@     installHaddockIndex    = Flag docIndexFile,     installDryRun          = Flag False,     installMaxBackjumps    = Flag defaultMaxBackjumps,-    installReorderGoals    = Flag False,-    installIndependentGoals= Flag False,-    installShadowPkgs      = Flag False,-    installStrongFlags     = Flag False,+    installReorderGoals    = Flag (ReorderGoals False),+    installCountConflicts  = Flag (CountConflicts True),+    installIndependentGoals= Flag (IndependentGoals False),+    installShadowPkgs      = Flag (ShadowPkgs False),+    installStrongFlags     = Flag (StrongFlags False),+    installAllowBootLibInstalls = Flag (AllowBootLibInstalls False),     installReinstall       = Flag False,-    installAvoidReinstalls = 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+    installOfflineMode     = Flag False,+    installProjectFileName = mempty   }   where     docIndexFile = toPathTemplate ("$datadir" </> "doc"@@ -1210,7 +1482,7 @@ defaultMaxBackjumps = 2000  defaultSolver :: PreSolver-defaultSolver = Choose+defaultSolver = AlwaysModular  allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))@@ -1251,7 +1523,7 @@      ++ " continue working as long as bindir and datadir are left untouched.",   commandNotes        = Just $ \pname ->         ( case commandNotes-               $ Cabal.configureCommand defaultProgramConfiguration+               $ Cabal.configureCommand defaultProgramDb           of Just desc -> desc pname ++ "\n"              Nothing   -> ""         )@@ -1326,9 +1598,11 @@       optionSolverFlags showOrParseArgs                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })+                        installCountConflicts   (\v flags -> flags { installCountConflicts   = v })                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })                         installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })-                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v }) +++                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v })+                        installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) ++        [ option [] ["reinstall"]           "Install even if it means installing the same version again."@@ -1337,7 +1611,8 @@        , option [] ["avoid-reinstalls"]           "Do not select versions that would destructively overwrite installed packages."-          installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })+          (fmap asBool . installAvoidReinstalls)+          (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })           (yesNoOpt showOrParseArgs)        , option [] ["force-reinstalls"]@@ -1360,8 +1635,20 @@           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" (readP_to_E (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` parse))+                          (flagToList . fmap display))+       , option [] ["root-cmd"]-          "Command used to gain root privileges, when installing with --global."+          "(No longer supported, do not use.)"           installRootCmd (\v flags -> flags { installRootCmd = v })           (reqArg' "COMMAND" toFlag flagToList) @@ -1394,6 +1681,11 @@           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 })@@ -1407,10 +1699,20 @@       , 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)++      , option [] ["project-file"]+          "Set the name of the cabal.project file to search for in parent directories"+          installProjectFileName (\v flags -> flags {installProjectFileName = v})+          (reqArgFlag "FILE")       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"                                         -- avoids           ParseArgs ->@@ -1432,8 +1734,12 @@ -- * Upload flags -- ------------------------------------------------------------ +-- | Is this a candidate package or a package to be published?+data IsCandidate = IsCandidate | IsPublished+                 deriving Eq+ data UploadFlags = UploadFlags {-    uploadCheck       :: Flag Bool,+    uploadCandidate   :: Flag IsCandidate,     uploadDoc         :: Flag Bool,     uploadUsername    :: Flag Username,     uploadPassword    :: Flag Password,@@ -1443,7 +1749,7 @@  defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags {-    uploadCheck       = toFlag False,+    uploadCandidate   = toFlag IsCandidate,     uploadDoc         = toFlag False,     uploadUsername    = mempty,     uploadPassword    = mempty,@@ -1463,15 +1769,19 @@          "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",     commandDefaultFlags = defaultUploadFlags,     commandOptions      = \_ ->-      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })+      [optionVerbosity uploadVerbosity+       (\v flags -> flags { uploadVerbosity = v }) -      ,option ['c'] ["check"]-         "Do not upload, just do QA checks."-        uploadCheck (\v flags -> flags { uploadCheck = v })-        trueArg+      ,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. Cannot be used together with --check."+        ("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 @@ -1683,9 +1993,6 @@       , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })       ]   }-  where readMaybe s = case reads s of-                        [(x,"")]  -> Just x-                        _         -> Nothing  -- ------------------------------------------------------------ -- * SDist flags@@ -1698,7 +2005,7 @@   }   deriving (Show, Generic) -data ArchiveFormat = TargzFormat | ZipFormat -- | ...+data ArchiveFormat = TargzFormat | ZipFormat -- ...   deriving (Show, Eq)  defaultSDistExFlags :: SDistExFlags@@ -1936,12 +2243,14 @@ -- ------------------------------------------------------------  data ExecFlags = ExecFlags {-  execVerbosity :: Flag Verbosity+  execVerbosity :: Flag Verbosity,+  execDistPref  :: Flag FilePath } deriving Generic  defaultExecFlags :: ExecFlags defaultExecFlags = ExecFlags {-  execVerbosity = toFlag normal+  execVerbosity = toFlag normal,+  execDistPref  = NoFlag   }  execCommand :: CommandUI ExecFlags@@ -1982,9 +2291,12 @@        "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n",    commandDefaultFlags = defaultExecFlags,-  commandOptions      = \_ ->+  commandOptions      = \showOrParseArgs ->     [ optionVerbosity execVerbosity       (\v flags -> flags { execVerbosity = v })+    , Cabal.optionDistPref+       execDistPref (\d flags -> flags { execDistPref = d })+       showOrParseArgs     ]   } @@ -2067,7 +2379,7 @@              -> OptionField flags optionSolver get set =   option [] ["solver"]-    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.")+    ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")     get set     (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)                                  (toFlag `fmap` parse))@@ -2075,12 +2387,15 @@  optionSolverFlags :: ShowOrParseArgs                   -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)+                  -> (flags -> Flag ReorderGoals)     -> (Flag ReorderGoals     -> flags -> flags)+                  -> (flags -> Flag CountConflicts)   -> (Flag CountConflicts   -> 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)                   -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl =+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig+                  getsip setsip getstrfl setstrfl getib setib =   [ 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@@ -2088,23 +2403,37 @@                     (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."-      getrg setrg+      (fmap asBool . getrg)+      (setrg . fmap ReorderGoals)       (yesNoOpt showOrParseArgs)-  -- TODO: Disabled for now because it does not work as advertised (yet).+  , 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)+  -- TODO: Disabled for now because it may not be necessary {-   , 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."-      getig setig+      (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."-      getsip setsip+      (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)."-      getstrfl setstrfl+      (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)   ]  usageFlagsOrPackages :: String -> String -> String@@ -2137,8 +2466,8 @@   where     pkgidToDependency :: PackageIdentifier -> Dependency     pkgidToDependency p = case packageVersion p of-      Version [] _ -> Dependency (packageName p) anyVersion-      version      -> Dependency (packageName p) (thisVersion version)+      v | v == nullVersion -> Dependency (packageName p) anyVersion+        | otherwise        -> Dependency (packageName p) (thisVersion v)  showRepo :: RemoteRepo -> String showRepo repo = remoteRepoName repo ++ ":"
Distribution/Client/SetupWrapper.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.SetupWrapper@@ -16,28 +17,36 @@ -- runs it with the given arguments.  module Distribution.Client.SetupWrapper (-    setupWrapper,+    getSetup, runSetup, runSetupCommand, setupWrapper,     SetupScriptOptions(..),     defaultSetupScriptOptions,   ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version-         ( Version(..), VersionRange, anyVersion+         ( Version, mkVersion, versionNumbers, VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )-import Distribution.InstalledPackageInfo (installedUnitId)+import qualified Distribution.Backpack as Backpack import Distribution.Package-         ( UnitId(..), PackageIdentifier(..), PackageId,-           PackageName(..), Package(..), packageName-         , packageVersion, Dependency(..) )+         ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName+         , PackageIdentifier(..), packageVersion, packageName )+import Distribution.Types.Dependency import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)          , PackageDescription(..), specVersion          , BuildType(..), knownBuildTypes, defaultRenaming )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+#else import Distribution.PackageDescription.Parse-         ( readPackageDescription )+         ( readGenericPackageDescription )+#endif import Distribution.Simple.Configure          ( configCompilerEx ) import Distribution.Compiler@@ -49,11 +58,11 @@ import Distribution.Simple.Build.Macros          ( generatePackageVersionMacros ) import Distribution.Simple.Program-         ( ProgramConfiguration, emptyProgramConfiguration+         ( ProgramDb, emptyProgramDb          , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram          , ghcjsProgram ) import Distribution.Simple.Program.Find-         ( programSearchPathAsPATHVar )+         ( programSearchPathAsPATHVar, ProgramSearchPathEntry(ProgramSearchPathDir) ) import Distribution.Simple.Program.Run          ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip@@ -66,6 +75,8 @@          ( 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          ( defaultCabalDir ) import Distribution.Client.IndexUtils@@ -75,39 +86,36 @@ import Distribution.Simple.Setup          ( Flag(..) ) import Distribution.Simple.Utils-         ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing+         ( die', debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing          , createDirectoryIfMissingVerbose, installExecutableFile-         , copyFileVerbose, rewriteFile, intercalate )+         , copyFileVerbose, rewriteFileEx ) import Distribution.Client.Utils-         ( inDir, tryCanonicalizePath-         , existsAndIsMoreRecentThan, moreRecentFile-#if mingw32_HOST_OS+         ( inDir, tryCanonicalizePath, withExtraPathEnv+         , existsAndIsMoreRecentThan, moreRecentFile, withEnv+#ifdef mingw32_HOST_OS          , canonicalizePathNoThrow #endif          )++import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text          ( display ) import Distribution.Utils.NubList          ( toNubListR ) import Distribution.Verbosity-         ( Verbosity ) import Distribution.Compat.Exception          ( catchIO )+import Distribution.Compat.Stack  import System.Directory    ( doesFileExist ) import System.FilePath     ( (</>), (<.>) ) import System.IO           ( Handle, hPutStr ) import System.Exit         ( ExitCode(..), exitWith )-import System.Process      ( runProcess, waitForProcess )-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ( (<$>), (<*>) )-import Data.Monoid         ( mempty )-#endif-import Control.Monad       ( when, unless )-import Data.List           ( find, foldl1' )-import Data.Maybe          ( fromMaybe, isJust )-import Data.Char           ( isSpace )+import System.Process      ( createProcess, StdStream(..), proc, waitForProcess+                           , ProcessHandle )+import qualified System.Process as Process+import Data.List           ( foldl1' ) import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )  #ifdef mingw32_HOST_OS@@ -120,6 +128,25 @@ 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@@ -129,6 +156,8 @@ -- -- 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@@ -155,14 +184,16 @@     usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,     usePackageIndex          :: Maybe InstalledPackageIndex,-    useProgramConfig         :: ProgramConfiguration,+    useProgramDb             :: ProgramDb,     useDistPref              :: FilePath,     useLoggingHandle         :: Maybe Handle,     useWorkingDir            :: Maybe FilePath,+    -- | Extra things to add to PATH when invoking the setup script.+    useExtraPathEnv          :: [FilePath],     forceExternalSetupMethod :: Bool,      -- | List of dependencies to use when building Setup.hs.-    useDependencies :: [(UnitId, PackageId)],+    useDependencies :: [(ComponentId, PackageId)],      -- | Is the list of setup dependencies exclusive?     --@@ -209,7 +240,12 @@     -- 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+    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@@ -223,88 +259,170 @@     useDependencies          = [],     useDependenciesExclusive = False,     useVersionMacros         = False,-    useProgramConfig         = emptyProgramConfiguration,+    useProgramDb             = emptyProgramDb,     useDistPref              = defaultDistPref,     useLoggingHandle         = Nothing,     useWorkingDir            = Nothing,+    useExtraPathEnv          = [],     useWin32CleanHack        = False,     forceExternalSetupMethod = False,-    setupCacheLock           = Nothing+    setupCacheLock           = Nothing,+    isInteractive            = False   } -setupWrapper :: Verbosity-             -> SetupScriptOptions-             -> Maybe PackageDescription-             -> CommandUI flags-             -> (Version -> flags)-             -> [String]-             -> IO ()-setupWrapper verbosity options mpkg cmd flags extraArgs = do+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 setupMethod = determineSetupMethod options' buildType'-      options'    = options {+  let options'    = options {                       useCabalVersion = intersectVersionRanges                                           (useCabalVersion options)                                           (orLaterVersion (specVersion pkg))                     }       buildType'  = fromMaybe Custom (buildType pkg)-      mkArgs cabalLibVersion = commandName cmd-                             : commandShowOptions cmd (flags cabalLibVersion)-                            ++ extraArgs   checkBuildType buildType'-  setupMethod verbosity options' (packageId pkg) buildType' mkArgs+  (version, method, options'') <-+    getSetupMethod verbosity options' pkg buildType'+  return Setup { setupMethod = method+               , setupScriptOptions = options''+               , setupVersion = version+               , setupBuildType = buildType'+               , setupPackage = pkg+               }   where     getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options))-         >>= readPackageDescription verbosity+         >>= readGenericPackageDescription verbosity          >>= return . packageDescription      checkBuildType (UnknownBuildType name) =-      die $ "The build-type '" ++ name ++ "' is not known. Use one of: "+      die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: "          ++ intercalate ", " (map display knownBuildTypes) ++ "."     checkBuildType _ = return () + -- | 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. ---determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod-determineSetupMethod options buildType'-    -- This order is picked so that it's stable. The build type and-    -- required cabal version are external info, coming from .cabal-    -- files and the command line. Those do switch between the-    -- external and self & internal methods, but that info itself can-    -- be considered stable. The logging and force-external conditions-    -- are internally generated choices but now these only switch-    -- between the self and internal setup methods, which are-    -- consistent with each other.-  | buildType' == Custom             = externalSetupMethod-  | maybe False (cabalVersion /=)-        (useCabalSpecVersion options)- || not (cabalVersion `withinRange`-         useCabalVersion options)    = externalSetupMethod+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 = selfExecSetupMethod-  | otherwise                        = internalSetupMethod+    || forceExternalSetupMethod options =+        return (cabalVersion, SelfExecMethod, options)+  | otherwise = return (cabalVersion, InternalMethod, options) -type SetupMethod = Verbosity-                -> SetupScriptOptions-                -> PackageIdentifier-                -> BuildType-                -> (Version -> [String]) -> IO ()+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 [1,25] = 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 | 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))+            _ -> 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+             -> [String]+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  setup <- getSetup verbosity options mpkg+  runSetupCommand verbosity setup cmd (flags $ setupVersion setup) extraArgs+ -- ------------------------------------------------------------ -- * Internal SetupMethod -- ------------------------------------------------------------ -internalSetupMethod :: SetupMethod-internalSetupMethod verbosity options _ bt mkargs = do-  let args = mkargs cabalVersion-  debug verbosity $ "Using internal setup method with build-type " ++ show bt-                 ++ " and args:\n  " ++ show args-  inDir (useWorkingDir options) $-    buildTypeAction bt args+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) $+        buildTypeAction bt args  buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple    = Simple.defaultMainArgs@@ -314,16 +432,46 @@ buildTypeAction Custom               = error "buildTypeAction Custom" buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" ++-- | @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+#if MIN_VERSION_process(1,2,0)+                     , Process.delegate_ctlc = _delegate+#endif+                     }+  return ph+  where+    mbToStd :: Maybe Handle -> StdStream+    mbToStd Nothing = Inherit+    mbToStd (Just hdl) = UseHandle hdl -- ------------------------------------------------------------ -- * Self-Exec SetupMethod -- ------------------------------------------------------------ -selfExecSetupMethod :: SetupMethod-selfExecSetupMethod verbosity options _pkg bt mkargs = do+selfExecSetupMethod :: SetupRunner+selfExecSetupMethod verbosity options bt args0 = do   let args = ["act-as-setup",               "--build-type=" ++ display bt,-              "--"] ++ mkargs cabalVersion-  debug verbosity $ "Using self-exec internal setup method with build-type "+              "--"] ++ 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)@@ -333,12 +481,14 @@                                     ++ show logHandle    searchpath <- programSearchPathAsPATHVar-                (getProgramSearchPath (useProgramConfig options))-  env        <- getEffectiveEnvironment [("PATH", Just searchpath)]--  process <- runProcess path args+                (map ProgramSearchPathDir (useExtraPathEnv options) +++                 getProgramSearchPath (useProgramDb options))+  env       <- getEffectiveEnvironment [("PATH", Just searchpath)+                                        ,("HASKELL_DIST_DIR", Just (useDistPref options))]+  process <- runProcess' path args              (useWorkingDir options) env Nothing              (useLoggingHandle options) (useLoggingHandle options)+             (isInteractive options)   exitCode <- waitForProcess process   unless (exitCode == ExitSuccess) $ exitWith exitCode @@ -346,8 +496,62 @@ -- * External SetupMethod -- ------------------------------------------------------------ -externalSetupMethod :: SetupMethod-externalSetupMethod verbosity options pkg bt mkargs = do+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))]++      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+      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)@@ -359,13 +563,29 @@                cabalLibVersion mCabalLibInstalledPkgId           else compileSetupExecutable   options'                cabalLibVersion mCabalLibInstalledPkgId False-  invokeSetupScript options' path (mkargs cabalLibVersion) +  -- 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-  workingDir       = case fromMaybe "" (useWorkingDir options) of-                       []  -> "."-                       dir -> dir-  setupDir         = workingDir </> useDistPref options </> "setup"+  setupDir         = workingDir options </> useDistPref options </> "setup"   setupVersionFile = setupDir   </> "setup" <.> "version"   setupHs          = setupDir   </> "setup" <.> "hs"   setupProgFile    = setupDir   </> "setup" <.> exeExtension@@ -374,12 +594,12 @@   useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)    maybeGetInstalledPackages :: SetupScriptOptions -> Compiler-                            -> ProgramConfiguration -> IO InstalledPackageIndex-  maybeGetInstalledPackages options' comp conf =+                            -> ProgramDb -> IO InstalledPackageIndex+  maybeGetInstalledPackages options' comp progdb =     case usePackageIndex options' of       Just index -> return index       Nothing    -> getInstalledPackages verbosity-                    comp (usePackageDB options') conf+                    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@@ -393,10 +613,10 @@   --   -- The version chosen here must match the one used in 'compileSetupExecutable'   -- (See issue #3433).-  cabalLibVersionToUse :: IO (Version, Maybe UnitId+  cabalLibVersionToUse :: IO (Version, Maybe ComponentId                              ,SetupScriptOptions)   cabalLibVersionToUse =-    case find (hasCabal . snd) (useDependencies options) of+    case find (isCabalPkgId . snd) (useDependencies options) of       Just (unitId, pkgId) -> do         let version = pkgVersion pkgId         updateSetupScript version bt@@ -439,14 +659,11 @@       writeSetupVersionFile version =           writeFile setupVersionFile (show version ++ "\n") -      hasCabal (PackageIdentifier (PackageName "Cabal") _) = True-      hasCabal _                                           = False--      installedVersion :: IO (Version, Maybe UnitId+      installedVersion :: IO (Version, Maybe InstalledPackageId                              ,SetupScriptOptions)       installedVersion = do-        (comp,    conf,    options')  <- configureCompiler options-        (version, mipkgid, options'') <- installedCabalVersion options' comp conf+        (comp,    progdb,  options')  <- configureCompiler options+        (version, mipkgid, options'') <- installedCabalVersion options' comp progdb         updateSetupScript version bt         writeSetupVersionFile version         return (version, mipkgid, options'')@@ -463,7 +680,7 @@   updateSetupScript _ Custom = do     useHs  <- doesFileExist customSetupHs     useLhs <- doesFileExist customSetupLhs-    unless (useHs || useLhs) $ die+    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@@ -471,38 +688,38 @@                     then copyFileVerbose verbosity src setupHs                     else runSimplePreProcessor ppUnlit src setupHs verbosity     where-      customSetupHs   = workingDir </> "Setup.hs"-      customSetupLhs  = workingDir </> "Setup.lhs"+      customSetupHs   = workingDir options </> "Setup.hs"+      customSetupLhs  = workingDir options </> "Setup.lhs"    updateSetupScript cabalLibVersion _ =-    rewriteFile setupHs (buildTypeScript cabalLibVersion)+    rewriteFileEx verbosity setupHs (buildTypeScript cabalLibVersion)    buildTypeScript :: Version -> String   buildTypeScript cabalLibVersion = case bt of     Simple    -> "import Distribution.Simple; main = defaultMain\n"     Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= Version [1,3,10] []+              ++ if cabalLibVersion >= mkVersion [1,3,10]                    then "autoconfUserHooks\n"                    else "defaultUserHooks\n"     Make      -> "import Distribution.Make; main = defaultMain\n"     Custom             -> error "buildTypeScript Custom"     UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" -  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration-                        -> IO (Version, Maybe UnitId+  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb+                        -> IO (Version, Maybe InstalledPackageId                               ,SetupScriptOptions)-  installedCabalVersion options' compiler conf = do-    index <- maybeGetInstalledPackages options' compiler conf-    let cabalDep   = Dependency (PackageName "Cabal") (useCabalVersion options')+  installedCabalVersion options' compiler progdb = do+    index <- maybeGetInstalledPackages options' compiler progdb+    let cabalDep   = Dependency (mkPackageName "Cabal") (useCabalVersion options')         options''  = options' { usePackageIndex = Just index }     case PackageIndex.lookupDependency index cabalDep of-      []   -> die $ "The package '" ++ display (packageName pkg)+      []   -> die' verbosity $ "The package '" ++ display (packageName pkg)                  ++ "' requires Cabal library version "                  ++ display (useCabalVersion options)                  ++ " but no suitable version is installed."       pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs               in return (packageVersion ipkginfo-                        ,Just . installedUnitId $ ipkginfo, options'')+                        ,Just . IPI.installedComponentId $ ipkginfo, options'')    bestVersion :: (a -> Version) -> [a] -> a   bestVersion f = firstMaximumBy (comparing (preference . f))@@ -528,27 +745,27 @@         where           sameVersion      = version == cabalVersion           sameMajorVersion = majorVersion version == majorVersion cabalVersion-          majorVersion     = take 2 . versionBranch-          stableVersion    = case versionBranch version of+          majorVersion     = take 2 . versionNumbers+          stableVersion    = case versionNumbers version of                                (_:x:_) -> even x                                _       -> False           latestVersion    = version    configureCompiler :: SetupScriptOptions-                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)+                    -> IO (Compiler, ProgramDb, SetupScriptOptions)   configureCompiler options' = do-    (comp, conf) <- case useCompiler options' of-      Just comp -> return (comp, useProgramConfig options')-      Nothing   -> do (comp, _, conf) <-+    (comp, progdb) <- case useCompiler options' of+      Just comp -> return (comp, useProgramDb options')+      Nothing   -> do (comp, _, progdb) <-                         configCompilerEx (Just GHC) Nothing Nothing-                        (useProgramConfig options') verbosity-                      return (comp, conf)+                        (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 conf-    return (comp, conf, options' { useCompiler      = Just comp,-                                   usePackageIndex  = Just index,-                                   useProgramConfig = conf })+    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.@@ -575,7 +792,7 @@   -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.   getCachedSetupExecutable :: SetupScriptOptions-                           -> Version -> Maybe UnitId+                           -> Version -> Maybe InstalledPackageId                            -> IO FilePath   getCachedSetupExecutable options' cabalLibVersion                            maybeCabalLibInstalledPkgId = do@@ -599,7 +816,7 @@           installExecutableFile verbosity src cachedSetupProgFile           -- Do not strip if we're using GHCJS, since the result may be a script           when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $-            Strip.stripExe verbosity platform (useProgramConfig options')+            Strip.stripExe verbosity platform (useProgramDb options')               cachedSetupProgFile     return cachedSetupProgFile       where@@ -610,7 +827,7 @@   -- Currently this is GHC/GHCJS only. It should really be generalised.   --   compileSetupExecutable :: SetupScriptOptions-                         -> Version -> Maybe UnitId -> Bool+                         -> Version -> Maybe ComponentId -> Bool                          -> IO FilePath   compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId                          forceCompile = do@@ -619,8 +836,8 @@     let outOfDate = setupHsNewer || cabalVersionNewer     when (outOfDate || forceCompile) $ do       debug verbosity "Setup executable needs to be updated, compiling..."-      (compiler, conf, options'') <- configureCompiler options'-      let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+      (compiler, progdb, options'') <- configureCompiler options'+      let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion           (program, extraOpts)             = case compilerFlavor compiler of                       GHCJS -> (ghcjsProgram, ["-build-runner"])@@ -638,19 +855,20 @@           -- Both of these options should be enabled for packages that have           -- opted-in and declared a custom-settup stanza.           ---          hasCabal (_, PackageIdentifier (PackageName "Cabal") _) = True-          hasCabal _                                              = False-           selectedDeps | useDependenciesExclusive options'                                    = useDependencies options'                        | otherwise = useDependencies options' ++-                                     if any hasCabal (useDependencies options')+                                     if any (isCabalPkgId . snd) (useDependencies options')                                      then []                                      else cabalDep-          addRenaming (ipid, pid) = (ipid, pid, defaultRenaming)+          addRenaming (ipid, _) =+            -- Assert 'DefUnitId' invariant+            (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming)           cppMacrosFile = setupDir </> "setup_macros.h"           ghcOptions = mempty {-              ghcOptVerbosity       = Flag verbosity+              -- 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@@ -658,7 +876,7 @@             , ghcOptHiDir           = Flag setupDir             , ghcOptSourcePathClear = Flag True             , ghcOptSourcePath      = case bt of-                                      Custom -> toNubListR [workingDir]+                                      Custom -> toNubListR [workingDir options']                                       _      -> mempty             , ghcOptPackageDBs      = usePackageDB options''             , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')@@ -670,73 +888,17 @@             }       let ghcCmdLine = renderGhcOptions compiler platform ghcOptions       when (useVersionMacros options') $-        rewriteFile cppMacrosFile (generatePackageVersionMacros-                                     [ pid | (_ipid, pid) <- selectedDeps ])+        rewriteFileEx verbosity cppMacrosFile+            (generatePackageVersionMacros (map snd selectedDeps))       case useLoggingHandle options of-        Nothing          -> runDbProgram verbosity program conf ghcCmdLine+        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-                                         conf ghcCmdLine+                                         progdb ghcCmdLine                                hPutStr logHandle output     return setupProgFile -  invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO ()-  invokeSetupScript options' path args = do-    info verbosity $ unwords (path : args)-    case useLoggingHandle options' of-      Nothing        -> return ()-      Just logHandle -> info verbosity $ "Redirecting build log to "-                                      ++ show logHandle -    -- 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.-#if mingw32_HOST_OS-    -- setupProgFile may not exist if we're using a cached program-    setupProgFile' <- canonicalizePathNoThrow setupProgFile-    let win32CleanHackNeeded = (useWin32CleanHack options')-                               -- Skip when a cached setup script is used.-                               && setupProgFile' `equalFilePath` path'-    if win32CleanHackNeeded then doWin32CleanHack path' else doInvoke path'-#else-    doInvoke path'-#endif--    where-      doInvoke path' = do-        searchpath <- programSearchPathAsPATHVar-                      (getProgramSearchPath (useProgramConfig options'))-        env        <- getEffectiveEnvironment [("PATH", Just searchpath)]--        process <- runProcess path' args-                   (useWorkingDir options') env Nothing-                   (useLoggingHandle options') (useLoggingHandle options')-        exitCode <- waitForProcess process-        unless (exitCode == ExitSuccess) $ exitWith exitCode--#if mingw32_HOST_OS-      doWin32CleanHack path' = do-        info verbosity $ "Using the Win32 clean hack."-        -- Recursively removes the temp dir on exit.-        withTempDirectory verbosity workingDir "cabal-tmp" $ \tmpDir ->-            bracket (moveOutOfTheWay tmpDir path')-                    (maybeRestore path')-                    doInvoke--      moveOutOfTheWay tmpDir path' = do-        let newPath = tmpDir </> "setup" <.> exeExtension-        Win32.moveFile path' newPath-        return newPath--      maybeRestore oldPath path' = do-        let oldPathDir = takeDirectory oldPath-        oldPathDirExists <- doesDirectoryExist oldPathDir-        -- 'setup clean' didn't complete, 'dist/setup' still exists.-        when oldPathDirExists $-          Win32.moveFile path' oldPath-#endif+isCabalPkgId :: PackageIdentifier -> Bool+isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
+ Distribution/Client/SolverInstallPlan.hs view
@@ -0,0 +1,445 @@+{-# 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.Package+         ( PackageIdentifier(..), Package(..), PackageName+         , HasUnitId(..), PackageId, packageVersion, packageName )+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Text+         ( display )++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 Data.List+         ( intercalate )+import Data.Maybe+         ( fromMaybe, catMaybes )+import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Graph (Graph, IsNode(..))+import qualified Data.Graph as OldGraph+import qualified Distribution.Compat.Graph as Graph+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Array ((!))+import Data.Typeable++type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc++type SolverPlanIndex = Graph SolverPlanPackage++data SolverInstallPlan = SolverInstallPlan {+    planIndex      :: !SolverPlanIndex,+    planIndepGoals :: !IndependentGoals+  }+  deriving (Typeable)++{-+-- | 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"+-}++mkInstallPlan :: SolverPlanIndex+              -> IndependentGoals+              -> SolverInstallPlan+mkInstallPlan index indepGoals =+    SolverInstallPlan {+      planIndex      = index,+      planIndepGoals = indepGoals+    }++instance Binary SolverInstallPlan where+    put SolverInstallPlan {+              planIndex      = index,+              planIndepGoals = indepGoals+        } = put (index, indepGoals)++    get = do+      (index, indepGoals) <- get+      return $! mkInstallPlan index indepGoals++showPlanIndex :: [SolverPlanPackage] -> String+showPlanIndex = intercalate "\n" . map showPlanPackage++showInstallPlan :: SolverInstallPlan -> String+showInstallPlan = showPlanIndex . toList++showPlanPackage :: SolverPlanPackage -> String+showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg)+                                            ++ " (" ++ display (installedUnitId ipkg)+                                            ++ ")"+showPlanPackage (Configured  spkg)   = "Configured " ++ display (packageId 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 (mkInstallPlan index indepGoals)+    probs -> Left probs++toList :: SolverInstallPlan -> [SolverPlanPackage]+toList = Graph.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 " ++ display (packageId pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ display name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ display pkg ++ " requires "+                            ++ display (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ display (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+       (catMaybes+        (map+         (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 <- Graph.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)+           . Graph.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 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 <- Graph.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 view
@@ -0,0 +1,168 @@+-- | 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 Control.Monad+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 =+    mapM_ (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 mapM_ 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"]+    mapM_ needIfExists (cSources bi ++ jsSources bi)+    -- A MASSIVE HACK to (1) make sure we rebuild when header+    -- files change, but (2) not have to rebuild when anything+    -- in extra-src-files changes (most of these won't affect+    -- compilation).  It would be even better if we knew on a+    -- per-component basis which headers would be used but that+    -- seems to be too difficult.+    mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr))+    forM_ (installIncludes bi) $ \f ->+        findFileMonitored ("." : includeDirs bi) f+            >>= maybe (return ()) need+  where+    findNeededModules exts =+        mapM_ (findNeededModule exts)+              (modules ++ otherModules bi)+    findNeededModule exts m =+        findFileWithExtensionMonitored+            (ppSuffixes knownSuffixHandlers ++ exts)+            (hsSourceDirs bi)+            (toFilePath m)+          >>= maybe (return ()) need
Distribution/Client/SrcDist.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE FlexibleContexts #-} -- Implements the \"@.\/cabal sdist@\" command, which creates a source -- distribution for this package.  That is, packs up the source code -- into a tarball, making use of the corresponding Cabal module.@@ -18,11 +20,16 @@          ( PackageDescription ) import Distribution.PackageDescription.Configuration          ( flattenPackageDescription )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+#else import Distribution.PackageDescription.Parse-         ( readPackageDescription )+         ( readGenericPackageDescription )+#endif import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, defaultPackageDesc-         , warn, die, notice, withTempDirectory )+         , warn, die', notice, withTempDirectory ) import Distribution.Client.Setup          ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup@@ -33,7 +40,7 @@ import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display ) import Distribution.Verbosity (Verbosity, normal, lessVerbose)-import Distribution.Version   (Version(..), orLaterVersion)+import Distribution.Version   (mkVersion, orLaterVersion, intersectVersionRanges)  import Distribution.Client.Utils   (tryFindAddSourcePackageDesc)@@ -50,8 +57,9 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do   pkg <- liftM flattenPackageDescription-    (readPackageDescription verbosity =<< defaultPackageDesc verbosity)-  let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)+    (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity)+  let withDir :: (FilePath -> IO a) -> IO a+      withDir = if not needMakeArchive then \f -> f tmpTargetDir                 else withTempDirectory verbosity tmpTargetDir "sdist."   -- 'withTempDir' fails if we don't create 'tmpTargetDir'...   when needMakeArchive $@@ -94,8 +102,8 @@       -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and       -- '--list-sources' in 1.17.       useCabalVersion = if isListSources-                        then orLaterVersion $ Version [1,17,0] []-                        else orLaterVersion $ Version [1,12,0] []+                        then orLaterVersion $ mkVersion [1,17,0]+                        else orLaterVersion $ mkVersion [1,12,0]       }     format        = fromFlag (sDistFormat exflags)     createArchive = case format of@@ -140,7 +148,7 @@                       Nothing Nothing Nothing Nothing     exitCode <- waitForProcess hnd     unless (exitCode == ExitSuccess) $-      die $ "Generating the zip file failed "+      die' verbosity $ "Generating the zip file failed "          ++ "(zip returned exit code " ++ show exitCode ++ ")"     notice verbosity $ "Source zip archive created: " ++ zipfile   where@@ -148,12 +156,13 @@  -- | 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).-allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]-allPackageSourceFiles verbosity packageDir = do+allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath+                         -> IO [FilePath]+allPackageSourceFiles verbosity setupOpts0 packageDir = do   pkg <- do     let err = "Error reading source files of package."-    desc <- tryFindAddSourcePackageDesc packageDir err-    flattenPackageDescription `fmap` readPackageDescription verbosity desc+    desc <- tryFindAddSourcePackageDesc verbosity packageDir err+    flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc   globalTmp <- getTemporaryDirectory   withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do   let file      = tempDir </> "cabal-sdist-list-sources"@@ -162,9 +171,11 @@                                   then lessVerbose verbosity else verbosity,         sDistListSources = Flag file         }-      setupOpts = defaultSetupScriptOptions {+      setupOpts = setupOpts0 {         -- 'sdist --list-sources' was introduced in Cabal 1.18.-        useCabalVersion = orLaterVersion $ Version [1,18,0] [],+        useCabalVersion = intersectVersionRanges+                            (orLaterVersion $ mkVersion [1,18,0])+                            (useCabalVersion setupOpts0),         useWorkingDir = Just packageDir         }
+ Distribution/Client/Store.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE 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.Compat.FileLock++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+import           Distribution.Text++import           Data.Set (Set)+import qualified Data.Set as Set+import           Control.Exception+import           System.FilePath+import           System.Directory+import           System.IO+++-- $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) -- ^ 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 <- 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 " ++ display compid </> display 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++            debug verbosity $+              "Installed store entry " ++ display compid </> display 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+    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 "+                      ++ display compid </> display unitid+        hLock h ExclusiveLock+      return h++    releaseLock = hClose+
+ Distribution/Client/TargetSelector.hs view
@@ -0,0 +1,2246 @@+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- 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(..),+    SubComponentTarget(..),+    QualLevel(..),+    componentKind,++    -- * Reading target selectors+    readTargetSelectors,+    TargetSelectorProblem(..),+    reportTargetSelectorProblems,+    showTargetSelector,+    TargetString,+    showTargetString,+    parseTargetString,+    -- ** non-IO+    readTargetSelectorsWith,+    DirActions(..),+    defaultDirActions,+  ) where++import Distribution.Package+         ( Package(..), PackageId, PackageIdentifier(..), packageName+         , mkPackageName )+import Distribution.Version+         ( mkVersion )+import Distribution.Types.UnqualComponentName ( unUnqualComponentName )+import Distribution.Client.Types+         ( PackageLocation(..) )++import Distribution.Verbosity+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(..)+         , pkgComponents, componentName, componentBuildInfo )+import Distribution.Types.ForeignLib++import Distribution.Text+         ( display, simpleParse )+import Distribution.Simple.Utils+         ( die', lowercase, ordNub )+import Distribution.Client.Utils+         ( makeRelativeCanonical )++import Data.Either+         ( partitionEithers )+import Data.Function+         ( on )+import Data.List+         ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )+import Data.Maybe+         ( maybeToList )+import Data.Ord+         ( comparing )+import Distribution.Compat.Binary (Binary)+import GHC.Generics (Generic)+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Lazy   as Map.Lazy+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+#else+import qualified Data.Map as Map.Lazy+import qualified Data.Map as Map+import Data.Map (Map)+#endif+import qualified Data.Set as Set+import Control.Arrow ((&&&))+import Control.Monad+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..), (<$>))+#endif+import Control.Applicative (Alternative(..))+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import Distribution.ParseUtils+         ( readPToMaybe )+import Data.Char+         ( isSpace, isAlphaNum )+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 )+++-- ------------------------------------------------------------+-- * 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 pkg =++     -- | A package as a whole: the default components for the package or all+     -- components of a particular kind.+     --+     TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter)++     -- | All packages, or all components of a particular kind in all packages.+     --+   | TargetAllPackages (Maybe ComponentKindFilter)++     -- | A specific component in a package.+     --+   | TargetComponent pkg ComponentName SubComponentTarget+  deriving (Eq, Ord, Functor, Show, Generic)++-- | Does this 'TargetPackage' selector arise from syntax referring to a+-- packge 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.+   | FileTarget   FilePath+  deriving (Eq, Ord, Show, Generic)++instance Binary 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 :: [SourcePackage (PackageLocation a)]+                    -> [String]+                    -> IO (Either [TargetSelectorProblem]+                                  [TargetSelector PackageId])+readTargetSelectors = readTargetSelectorsWith defaultDirActions++readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m+                        -> [SourcePackage (PackageLocation a)]+                        -> [String]+                        -> m (Either [TargetSelectorProblem]+                                     [TargetSelector PackageId])+readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs =+    case parseTargetStrings targetStrs of+      ([], utargets) -> do+        utargets' <- mapM (getTargetStringFileStatus dirActions) utargets+        pkgs'     <- mapM (selectPackageInfo dirActions) pkgs+        cwd       <- getCurrentDirectory+        let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs'+        case resolveTargetSelectors cwdPkg otherPkgs utargets' of+          ([], btargets) -> return (Right (map (fmap packageId) btargets))+          (problems, _)  -> return (Left problems)+      (strs, _)          -> return (Left (map TargetSelectorUnrecognised strs))+  where+    selectCwdPackage :: FilePath+                     -> [PackageInfo]+                     -> ([PackageInfo], [PackageInfo])+    selectCwdPackage cwd pkgs' =+        let (cwdpkg, others) = partition isPkgDirCwd pkgs'+         in (cwdpkg, others)+      where+        isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) }+          | dir == cwd = True+        isPkgDirCwd _  = False++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 :: Package p => TargetSelector p -> String+showTargetSelector ts =+  let (t':_) = [ t | ql <- [QL1 .. QLFull]+                   , t  <- renderTargetSelector ql ts ]+   in showTargetString (forgetFileStatus t')++showTargetSelectorKind :: TargetSelector a -> 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"+  TargetAllPackages Nothing                    -> "all-packages"+  TargetAllPackages (Just _)                   -> "all-packages:filter"+  TargetComponent _ _ WholeComponent           -> "component"+  TargetComponent _ _ ModuleTarget{}           -> "module"+  TargetComponent _ _ FileTarget{}             -> "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+++-- ------------------------------------------------------------+-- * Resolving target strings to target selectors+-- ------------------------------------------------------------+++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+--+resolveTargetSelectors :: [PackageInfo]     -- any pkg in the cur dir+                       -> [PackageInfo]     -- all the other local packages+                       -> [TargetStringFileStatus]+                       -> ([TargetSelectorProblem],+                           [TargetSelector PackageInfo])++-- default local dir target if there's no given target:+resolveTargetSelectors [] [] [] =+    ([TargetSelectorNoTargetsInProject], [])++resolveTargetSelectors [] _opinfo [] =+    ([TargetSelectorNoTargetsInCwd], [])++resolveTargetSelectors ppinfo _opinfo [] =+    ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing])+    --TODO: in future allow multiple packages in the same dir++resolveTargetSelectors ppinfo opinfo targetStrs =+    partitionEithers+  . map (resolveTargetSelector ppinfo opinfo)+  $ targetStrs++resolveTargetSelector :: [PackageInfo] -> [PackageInfo]+                      -> TargetStringFileStatus+                      -> Either TargetSelectorProblem+                                (TargetSelector PackageInfo)+resolveTargetSelector ppinfo opinfo targetStrStatus =+    case findMatch (matcher targetStrStatus) of++      Unambiguous _+        | projectIsEmpty -> Left TargetSelectorNoTargetsInProject++      Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter)+        | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr)+        | otherwise   -> Right (TargetPackage TargetImplicitCwd+                                              (head ppinfo) mkfilter)+                       --TODO: in future allow multiple packages in the same dir++      Unambiguous target -> Right target++      None errs+        | projectIsEmpty       -> Left TargetSelectorNoTargetsInProject+        | otherwise            -> Left (classifyMatchErrors errs)++      Ambiguous exactMatch targets ->+        case disambiguateTargetSelectors+               matcher targetStrStatus exactMatch+               targets of+          Right targets'   -> Left (TargetSelectorAmbiguous targetStr+                                       (map (fmap (fmap packageId)) targets'))+          Left ((m, ms):_) -> Left (MatchingInternalError targetStr+                                       (fmap packageId m)+                                       (map (fmap (map (fmap packageId))) ms))+          Left []          -> internalError "resolveTargetSelector"+  where+    matcher = matchTargetSelector ppinfo opinfo++    targetStr = forgetFileStatus targetStrStatus++    projectIsEmpty = null ppinfo && null opinfo++    classifyMatchErrors errs+      | not (null expected)+      = let (things, got:_) = unzip expected in+        TargetSelectorExpected targetStr 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)++-- | 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 PackageId)]++   | MatchingInternalError TargetString (TargetSelector PackageId)+                           [(TargetString, [TargetSelector PackageId])]+   | TargetSelectorUnrecognised String+     -- ^ Syntax error when trying to parse a target string.+   | TargetSelectorNoCurrentPackage TargetString+   | TargetSelectorNoTargetsInCwd+   | TargetSelectorNoTargetsInProject+  deriving (Show, Eq)++data QualLevel = QL1 | QL2 | QL3 | QLFull+  deriving (Eq, Enum, Show)++disambiguateTargetSelectors+  :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo))+  -> TargetStringFileStatus -> Bool+  -> [TargetSelector PackageInfo]+  -> Either [(TargetSelector PackageInfo,+              [(TargetString, [TargetSelector PackageInfo])])]+            [(TargetString, TargetSelector PackageInfo)]+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.+    matchResultsRenderings :: [(TargetSelector PackageInfo,+                                [TargetStringFileStatus])]+    matchResultsRenderings =+      [ (matchResult, matchRenderings)+      | matchResult <- matchResults+      , let matchRenderings =+              [ 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 PackageInfo))+    memoisedMatches =+        -- avoid recomputing the main one if it was an exact match+        (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults)+                       else id)+      $ Map.Lazy.fromList+          [ (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 PackageInfo,+                        [(TargetString, [TargetSelector PackageInfo])])+                       (TargetString, TargetSelector PackageInfo)]+    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 (ExactMatch _ matches) =+                            memoisedMatches Map.! rendering+                    ] )++      | (originalMatch, matchRenderings) <- matchResultsRenderings ]++    findUnambiguous :: TargetSelector PackageInfo+                    -> [TargetStringFileStatus]+                    -> Maybe TargetStringFileStatus+    findUnambiguous _ []     = Nothing+    findUnambiguous t (r:rs) =+      case memoisedMatches Map.! r of+        ExactMatch _ [t'] | fmap packageName t == fmap packageName t'+                         -> Just r+        ExactMatch _  _  -> findUnambiguous t rs+        InexactMatch _ _ -> internalError "InexactMatch"+        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 PackageInfo)+type Renderer = TargetSelector PackageId -> [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 :: Package p => QualLevel -> TargetSelector p+                     -> [TargetStringFileStatus]+renderTargetSelector ql ts =+    foldSyntax+      (++) (++)+      (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts))+      syntax+  where+    syntax = syntaxForms [] [] -- don't need pinfo for rendering++matchTargetSelector :: [PackageInfo] -> [PackageInfo]+                    -> TargetStringFileStatus+                    -> Match (TargetSelector PackageInfo)+matchTargetSelector ppinfo opinfo = \utarget ->+    nubMatchesBy ((==) `on` (fmap packageName)) $++    let ql = targetQualLevel utarget in+    foldSyntax+      (<|>) (<//>)+      (\ql' match _ -> guard (ql == ql') >> match utarget)+      syntax+  where+    syntax = syntaxForms ppinfo opinfo++    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 :: [PackageInfo] -> [PackageInfo] -> Syntax+syntaxForms ppinfo opinfo =+    -- 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+              , 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++        -- 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 = foldr1 AmbiguousAlternatives+    shadowingAlternatives = foldr1 ShadowingAlternatives+    pinfo  = ppinfo ++ opinfo+    cinfo  = concatMap pinfoComponents pinfo+    pcinfo = concatMap pinfoComponents ppinfo+    ocinfo = concatMap pinfoComponents opinfo+++-- | 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 :: Syntax+syntaxForm1Filter =+  syntaxForm1 render $ \str1 _fstatus1 -> do+    kfilter <- matchComponentKindFilter str1+    return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))+  where+    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =+      [TargetStringFileStatus1 (dispF kfilter) noFileStatus]+    render _ = []++-- Only used for TargetPackage TargetImplicitCwd+dummyPackageInfo :: PackageInfo+dummyPackageInfo =+    PackageInfo {+      pinfoId          = PackageIdentifier+                           (mkPackageName "dummyPackageInfo")+                           (mkVersion []),+      pinfoLocation    = unused,+      pinfoDirectory   = unused,+      pinfoPackageFile = unused,+      pinfoComponents  = unused+    }+  where+    unused = error "dummyPackageInfo"++-- | Syntax: package (name, dir or file)+--+-- > cabal build foo+-- > cabal build ../bar ../bar/bar.cabal+--+syntaxForm1Package :: [PackageInfo] -> Syntax+syntaxForm1Package pinfo =+  syntaxForm1 render $ \str1 fstatus1 -> do+    guardPackage            str1 fstatus1+    p <- matchPackage pinfo str1 fstatus1+    return (TargetPackage TargetExplicitNamed p Nothing)+  where+    render (TargetPackage TargetExplicitNamed p Nothing) =+      [TargetStringFileStatus1 (dispP p) noFileStatus]+    render _ = []++-- | Syntax: component+--+-- > cabal build foo+--+syntaxForm1Component :: [ComponentInfo] -> Syntax+syntaxForm1Component cs =+  syntaxForm1 render $ \str1 _fstatus1 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus1 (dispC p c) noFileStatus]+    render _ = []++-- | Syntax: module+--+-- > cabal build Data.Foo+--+syntaxForm1Module :: [ComponentInfo] -> 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 (cinfoPackage 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 :: [PackageInfo] -> 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, p) <- matchPackageDirectoryPrefix ps fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile+      return (TargetComponent p (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 :: [PackageInfo] -> Syntax+syntaxForm2PackageFilter ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    p <- matchPackage ps str1 fstatus1+    kfilter <- matchComponentKindFilter str2+    return (TargetPackage TargetExplicitNamed p (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+      [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]+    render _ = []++-- | Syntax: pkg : package name+--+-- > cabal build pkg:foo+--+syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax+syntaxForm2NamespacePackage pinfo =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardNamespacePackage   str1+    guardPackageName        str2+    p <- matchPackage pinfo str2 noFileStatus+    return (TargetPackage TargetExplicitNamed p Nothing)+  where+    render (TargetPackage TargetExplicitNamed p Nothing) =+      [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]+    render _ = []++-- | Syntax: package : component+--+-- > cabal build foo:foo+-- > cabal build ./foo:foo+-- > cabal build ./foo.cabal:foo+--+syntaxForm2PackageComponent :: [PackageInfo] -> Syntax+syntaxForm2PackageComponent ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      return (TargetComponent p (cinfoName c) WholeComponent)+    --TODO: the error here ought to say there's no component by that name in+    -- this package, and name the package+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]+    render _ = []++-- | Syntax: namespace : component+--+-- > cabal build lib:foo exe:foo+--+syntaxForm2KindComponent :: [ComponentInfo] -> Syntax+syntaxForm2KindComponent cs =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus2 (dispK 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 :: [PackageInfo] -> Syntax+syntaxForm2PackageModule ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardModuleName      str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ]+      (m,c) <- matchModuleNameAnd ms str2+      return (TargetComponent p (cinfoName c) (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 :: [ComponentInfo] -> 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 (cinfoPackage 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 :: [PackageInfo] -> Syntax+syntaxForm2PackageFile ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      (filepath, c) <- matchComponentFile (pinfoComponents p) str2+      return (TargetComponent p (cinfoName c) (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 :: [ComponentInfo] -> 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 (cinfoPackage 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 :: Syntax+syntaxForm3MetaCwdFilter =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespaceMeta str1+    guardNamespaceCwd str2+    kfilter <- matchComponentKindFilter str3+    return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))+  where+    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =+      [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]+    render _ = []++-- | Syntax: :pkg : package name+--+-- > cabal build :pkg:foo+--+syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax+syntaxForm3MetaNamespacePackage pinfo =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespaceMeta      str1+    guardNamespacePackage   str2+    guardPackageName        str3+    p <- matchPackage pinfo str3 noFileStatus+    return (TargetPackage TargetExplicitNamed p Nothing)+  where+    render (TargetPackage TargetExplicitNamed p Nothing) =+      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]+    render _ = []++-- | Syntax: package : namespace : component+--+-- > cabal build foo:lib:foo+-- > cabal build foo/:lib:foo+-- > cabal build foo.cabal:lib:foo+--+syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax+syntaxForm3PackageKindComponent ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    ckind <- matchComponentKind str2+    guardComponentName   str3+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str3+      return (TargetComponent p (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p 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 :: [PackageInfo] -> Syntax+syntaxForm3PackageComponentModule ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage str1 fstatus1+    guardComponentName str2+    guardModuleName    str3+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      orNoThingIn "component" (cinfoStrName c) $ do+        let ms = cinfoModules c+        m <- matchModuleName ms str3+        return (TargetComponent p (cinfoName c) (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)]+    render _ = []++-- | Syntax: namespace : component : module+--+-- > cabal build lib:foo:Data.Foo+--+syntaxForm3KindComponentModule :: [ComponentInfo] -> 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 (cinfoPackage c) (cinfoName c)+                              (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispK 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 :: [PackageInfo] -> Syntax+syntaxForm3PackageComponentFile ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentName (pinfoComponents p) str2+      orNoThingIn "component" (cinfoStrName c) $ do+        (filepath, _) <- matchComponentFile [c] str3+        return (TargetComponent p (cinfoName c) (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]+    render _ = []++-- | Syntax: namespace : component : filename+--+-- > cabal build lib:foo:Data/Foo.hs+--+syntaxForm3KindComponentFile :: [ComponentInfo] -> 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 (cinfoPackage c) (cinfoName c)+                              (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f]+    render _ = []++syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax+syntaxForm3NamespacePackageFilter ps =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespacePackage str1+    guardPackageName      str2+    p <- matchPackage  ps str2 noFileStatus+    kfilter <- matchComponentKindFilter str3+    return (TargetPackage TargetExplicitNamed p (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+      [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]+    render _ = []++--++syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax+syntaxForm4MetaNamespacePackageFilter ps =+  syntaxForm4 render $ \str1 str2 str3 str4 -> do+    guardNamespaceMeta    str1+    guardNamespacePackage str2+    guardPackageName      str3+    p <- matchPackage  ps str3 noFileStatus+    kfilter <- matchComponentKindFilter str4+    return (TargetPackage TargetExplicitNamed p (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed p (Just kfilter)) =+      [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component+--+-- > cabal build :pkg:foo:lib:foo+--+syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> 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+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str5+      return (TargetComponent p (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component : module : module+--+-- > cabal build :pkg:foo:lib:foo:module:Data.Foo+--+syntaxForm7MetaNamespacePackageKindComponentNamespaceModule+  :: [PackageInfo] -> 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+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str5+      orNoThingIn "component" (cinfoStrName c) $ do+        let ms = cinfoModules c+        m <- matchModuleName ms str7+        return (TargetComponent p (cinfoName c) (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus7 "" "pkg" (dispP p)+                               (dispK c) (dispC p c)+                               "module" (dispM m)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component : file : filename+--+-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs+--+syntaxForm7MetaNamespacePackageKindComponentNamespaceFile+  :: [PackageInfo] -> 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+    orNoThingIn "package" (display (packageName p)) $ do+      c <- matchComponentKindAndName (pinfoComponents p) ckind str5+      orNoThingIn "component" (cinfoStrName c) $ do+        (filepath,_) <- matchComponentFile [c] str7+        return (TargetComponent p (cinfoName c) (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus7 "" "pkg" (dispP p)+                               (dispK c) (dispC p c)+                               "file" f]+    render _ = []+++---------------------------------------+-- Syntax utils+--++type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo)+type Match2 = String -> FileStatus -> String+              -> Match (TargetSelector PackageInfo)+type Match3 = String -> FileStatus -> String -> String+              -> Match (TargetSelector PackageInfo)+type Match4 = String -> String -> String -> String+              -> Match (TargetSelector PackageInfo)+type Match5 = String -> String -> String -> String -> String+              -> Match (TargetSelector PackageInfo)+type Match7 = String -> String -> String -> String -> String -> String -> String+              -> Match (TargetSelector PackageInfo)++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 = display . packageName++dispC :: Package p => p -> ComponentName -> String+dispC = componentStringName++dispK :: ComponentName -> String+dispK = showComponentKindShort . componentKind++dispF :: ComponentKind -> String+dispF = showComponentKindFilterShort++dispM :: ModuleName -> String+dispM = display+++-------------------------------+-- Package and component info+--++data PackageInfo = PackageInfo {+       pinfoId          :: PackageId,+       pinfoLocation    :: PackageLocation (),+       pinfoDirectory   :: Maybe (FilePath, FilePath),+       pinfoPackageFile :: Maybe (FilePath, FilePath),+       pinfoComponents  :: [ComponentInfo]+     }+  -- not instance of Show due to recursive construction++data ComponentInfo = ComponentInfo {+       cinfoName    :: ComponentName,+       cinfoStrName :: ComponentStringName,+       cinfoPackage :: PackageInfo,+       cinfoSrcDirs :: [FilePath],+       cinfoModules :: [ModuleName],+       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles  :: [FilePath],+       cinfoJsFiles :: [FilePath]+     }+  -- not instance of Show due to recursive construction++type ComponentStringName = String++instance Package PackageInfo where+  packageId = pinfoId++selectPackageInfo :: (Applicative m, Monad m) => DirActions m+                  -> SourcePackage (PackageLocation a) -> m PackageInfo+selectPackageInfo dirActions@DirActions{..}+                  SourcePackage {+                    packageDescription = pkg,+                    packageSource      = 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 </> display (packageName pkg) <.> "cabal"+              filerel = dirrel </> display (packageName pkg) <.> "cabal"+          exists <- doesFileExist fileabs+          return ( Just (dirabs, dirrel)+                 , if exists then Just (fileabs, filerel) else Nothing+                 )+        _ -> return (Nothing, Nothing)+    let pinfo =+          PackageInfo {+            pinfoId          = packageId pkg,+            pinfoLocation    = fmap (const ()) loc,+            pinfoDirectory   = pkgdir,+            pinfoPackageFile = pkgfile,+            pinfoComponents  = selectComponentInfo pinfo+                                 (flattenPackageDescription pkg)+          }+    return pinfo+++selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo]+selectComponentInfo pinfo pkg =+    [ ComponentInfo {+        cinfoName    = componentName c,+        cinfoStrName = componentStringName pkg (componentName c),+        cinfoPackage = pinfo,+        cinfoSrcDirs = ordNub (hsSourceDirs bi),+--                       [ pkgroot </> srcdir+--                       | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo)+--                       , srcdir <- 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 :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg CLibName          = display (packageName pkg)+componentStringName _ (CSubLibName 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 (CSubLibName _) = LibKind+componentKind (CFLibName _)  = FLibKind+componentKind (CExeName   _) = ExeKind+componentKind (CTestName  _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: ComponentInfo -> 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 :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+matchPackage pinfo = \str fstatus ->+    orNoThingIn "project" "" $+          matchPackageName pinfo str+    <//> (matchPackageDir  pinfo str fstatus+     <|>  matchPackageFile pinfo str fstatus)+++matchPackageName :: [PackageInfo] -> String -> Match PackageInfo+matchPackageName ps = \str -> do+    guard (validPackageName str)+    orNoSuchThing "package" str+                  (map (display . packageName) ps) $+      increaseConfidenceFor $+        matchInexactly caseFold (display . packageName) ps str+++matchPackageDir :: [PackageInfo]+                -> String -> FileStatus -> Match PackageInfo+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@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ]+++matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo+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@PackageInfo{ 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 :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName cs str =+    orNoSuchThing "component" str (map cinfoStrName cs)+  $ increaseConfidenceFor+  $ matchInexactly caseFold cinfoStrName cs str+++matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String+                          -> Match ComponentInfo+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 simpleParse 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 display ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold display ms str+++matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)+matchModuleNameAnd ms str =+    orNoSuchThing "module" str (map (display . fst) ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold (display . fst) ms str+++------------------------------+-- Matching file targets+--++matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus+                            -> Match (FilePath, PackageInfo)+matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =+    increaseConfidenceFor $+      matchDirectoryPrefix pkgdirs filepath+  where+    pkgdirs = [ (dir, p)+              | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ]+matchPackageDirectoryPrefix _ _ = mzero+++matchComponentFile :: [ComponentInfo] -> String+                   -> Match (FilePath, ComponentInfo)+matchComponentFile cs str =+    orNoSuchThing "file" str [] $+        matchComponentModuleFile cs str+    <|> matchComponentOtherFile  cs str+++matchComponentOtherFile :: [ComponentInfo] -> String+                        -> Match (FilePath, ComponentInfo)+matchComponentOtherFile cs =+    matchFile+      [ (file, c)+      | c    <- cs+      , file <- cinfoHsFiles c+             ++ cinfoCFiles  c+             ++ cinfoJsFiles c+      ]+++matchComponentModuleFile :: [ComponentInfo] -> String+                         -> Match (FilePath, ComponentInfo)+matchComponentModuleFile cs str = do+    matchFile+      [ (normalise (d </> toFilePath m), c)+      | c <- cs+      , d <- cinfoSrcDirs c+      , m <- cinfoModules c+      ]+      (dropExtension (normalise str))++-- 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]+             | ExactMatch   Confidence [a]+             | InexactMatch Confidence [a]+  deriving Show++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 (ExactMatch   d xs) = ExactMatch   d (fmap f xs)+    fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)++instance Applicative Match where+    pure a = ExactMatch 0 [a]+    (<*>)  = ap++instance Alternative Match where+    empty = NoMatch 0 []+    (<|>) = matchPlus++instance Monad Match where+    return                  = pure+    NoMatch      d ms >>= _ = NoMatch d ms+    ExactMatch   d xs >>= f = addDepth d+                            $ msum (map f xs)+    InexactMatch d xs >>= f = addDepth d . forceInexact+                            $ msum (map f xs)++instance MonadPlus Match where+    mzero = empty+    mplus = matchPlus++(<//>) :: Match a -> Match a -> Match a+(<//>) = matchPlusShadowing++infixl 3 <//>++addDepth :: Confidence -> Match a -> Match a+addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs+addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs+addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs++forceInexact :: Match a -> Match a+forceInexact (ExactMatch d ys) = InexactMatch d ys+forceInexact m                 = m++-- | 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   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =+  ExactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a+matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a+matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =+  InexactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a+matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b+matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')+                                             | d1 >  d2  = a+                                             | d1 <  d2  = b+                                             | otherwise = NoMatch d1 (ms ++ ms')++-- | 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@(ExactMatch _ _)  _ = 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 = ExactMatch 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 (ExactMatch   d xs)   = ExactMatch   d (nubBy eq xs)+nubMatchesBy eq (InexactMatch d xs)   = InexactMatch d (nubBy eq xs)++-- | Lift a list of matches to an exact match.+--+exactMatches, inexactMatches :: [a] -> Match a++exactMatches [] = mzero+exactMatches xs = ExactMatch 0 xs++inexactMatches [] = mzero+inexactMatches xs = InexactMatch 0 xs++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+  ExactMatch   _ [x] -> Unambiguous x+  InexactMatch _ [x] -> Unambiguous x+  ExactMatch   _  [] -> error "findMatch: impossible: ExactMatch []"+  InexactMatch _  [] -> error "findMatch: impossible: InexactMatch []"+  ExactMatch   _  xs -> Ambiguous True  xs+  InexactMatch _  xs -> Ambiguous False xs++data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [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+++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase+++------------------------------+-- Example inputs+--++{-+ex1pinfo :: [PackageInfo]+ex1pinfo =+  [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $+    PackageInfo {+      pinfoId          = PackageIdentifier (mkPackageName "foo") (mkVersion [1]),+      pinfoLocation    = LocalUnpackedPackage "/the/foo",+      pinfoDirectory   = Just ("/the/foo", "foo"),+      pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"),+      pinfoComponents  = []+    }+  , PackageInfo {+      pinfoId          = PackageIdentifier (mkPackageName "bar") (mkVersion [1]),+      pinfoLocation    = LocalUnpackedPackage "/the/foo",+      pinfoDirectory   = Just ("/the/bar", "bar"),+      pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"),+      pinfoComponents  = []+    }+  ]+  where+    addComponent n ds ms p =+      p {+        pinfoComponents =+            ComponentInfo 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 :: [ComponentInfo]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}
Distribution/Client/Targets.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Targets@@ -41,28 +43,36 @@   disambiguatePackageName,    -- * User constraints+  UserQualifier(..),+  UserConstraintScope(..),   UserConstraint(..),   userConstraintPackageName,   readUserConstraint,   userToPackageConstraint,-  dispFlagAssignment,-  parseFlagAssignment,    ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Package-         ( Package(..), PackageName(..)-         , PackageIdentifier(..), packageName, packageVersion-         , Dependency(Dependency) )+         ( Package(..), PackageName, unPackageName, mkPackageName+         , PackageIdentifier(..), packageName, packageVersion )+import Distribution.Types.Dependency import Distribution.Client.Types-         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) )-import Distribution.Client.Dependency.Types-         ( PackageConstraint(..), ConstraintSource(..)-         , LabeledPackageConstraint(..) )+         ( PackageLocation(..)+         , ResolvedPkgLoc, UnresolvedSourcePackage ) +import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+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 Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Codec.Archive.Tar       as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar@@ -72,51 +82,44 @@          ( RepoContext(..) )  import Distribution.PackageDescription-         ( GenericPackageDescription, FlagName(..), FlagAssignment )-import Distribution.PackageDescription.Parse-         ( readPackageDescription, parsePackageDescription, ParseResult(..) )+         ( GenericPackageDescription, parseFlagAssignment ) import Distribution.Version-         ( Version(Version), thisVersion, anyVersion, isAnyVersion-         , VersionRange )+         ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM )+         ( die', warn, lowercase ) -import Data.List-         ( find, nub )-import Data.Maybe-         ( listToMaybe )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )+#else+import Distribution.PackageDescription.Parse+         ( readGenericPackageDescription, parseGenericPackageDescription, ParseResult(..) )+import Distribution.Simple.Utils+         ( fromUTF8, ignoreBOM )+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+#endif++-- import Data.List ( find, nub ) import Data.Either          ( partitionEithers )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Client.GZipUtils as GZipUtils-import Control.Monad (liftM)+import Control.Monad (mapM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP          ( (+++), (<++) )-import qualified Distribution.Compat.Semigroup as Semi-         ( Semigroup((<>)) )-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint-         ( (<>), (<+>) )-import Data.Char-         ( isSpace, isAlphaNum )+import Distribution.ParseUtils+         ( readPToMaybe ) import System.FilePath          ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory          ( doesFileExist, doesDirectoryExist ) import Network.URI          ( URI(..), URIAuth(..), parseAbsoluteURI )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary)  -- ------------------------------------------------------------ -- * User targets@@ -185,10 +188,10 @@       -- | A partially specified reference to a package (either source or      -- installed). It is specified by package name and optionally some-     -- additional constraints. Use a dependency resolver to pick a specific-     -- package satisfying these constraints.+     -- required properties. Use a dependency resolver to pick a specific+     -- package satisfying these properties.      ---     NamedPackage PackageName [PackageConstraint]+     NamedPackage PackageName [PackageProperty]       -- | A fully specified source package.      --@@ -203,24 +206,27 @@  pkgSpecifierConstraints :: Package pkg                         => PackageSpecifier pkg -> [LabeledPackageConstraint]-pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints+pkgSpecifierConstraints (NamedPackage name props) = map toLpc props   where-    toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget+    toLpc prop = LabeledPackageConstraint+                 (PackageConstraint (scopeToplevel name) prop)+                 ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg)  =     [LabeledPackageConstraint pc ConstraintSourceUserTarget]   where-    pc = PackageConstraintVersion (packageName pkg)-         (thisVersion (packageVersion pkg))+    pc = PackageConstraint+         (scopeToplevel $ packageName pkg)+         (PackagePropertyVersion $ thisVersion (packageVersion pkg))  -- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------  readUserTargets :: Verbosity -> [String] -> IO [UserTarget]-readUserTargets _verbosity targetStrs = do+readUserTargets verbosity targetStrs = do     (problems, targets) <- liftM partitionEithers                                  (mapM readUserTarget targetStrs)-    reportUserTargetProblems problems+    reportUserTargetProblems verbosity problems     return targets  @@ -236,10 +242,12 @@ readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr =     case testNamedTargets targetstr of-      Just (Dependency (PackageName "world") verrange)-        | verrange == anyVersion -> return (Right UserTargetWorld)-        | otherwise              -> return (Left  UserTargetBadWorldPkg)-      Just dep                   -> return (Right (UserTargetNamed dep))+      Just (Dependency pkgn verrange)+        | pkgn == mkPackageName "world"+          -> return $ if verrange == anyVersion+                      then Right UserTargetWorld+                      else Left  UserTargetBadWorldPkg+      Just dep -> return (Right (UserTargetNamed dep))       Nothing -> do         fileTarget <- testFileTargets targetstr         case fileTarget of@@ -302,19 +310,15 @@       where         pkgidToDependency :: PackageIdentifier -> Dependency         pkgidToDependency p = case packageVersion p of-          Version [] _ -> Dependency (packageName p) anyVersion-          version      -> Dependency (packageName p) (thisVersion version)--readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                     , all isSpace s ]+          v | v == nullVersion -> Dependency (packageName p) anyVersion+            | otherwise        -> Dependency (packageName p) (thisVersion v)  -reportUserTargetProblems :: [UserTargetProblem] -> IO ()-reportUserTargetProblems problems = do+reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()+reportUserTargetProblems verbosity problems = do     case [ target | UserTargetUnrecognised target <- problems ] of       []     -> return ()-      target -> die+      target -> die' verbosity               $ unlines                   [ "Unrecognised target '" ++ name ++ "'."                   | name <- target ]@@ -326,18 +330,18 @@      case [ () | UserTargetBadWorldPkg <- problems ] of       [] -> return ()-      _  -> die "The special 'world' target does not take any version."+      _  -> die' verbosity "The special 'world' target does not take any version."      case [ target | UserTargetNonexistantFile target <- problems ] of       []     -> return ()-      target -> die+      target -> die' verbosity               $ unlines                   [ "The file does not exist '" ++ name ++ "'."                   | name <- target ]      case [ target | UserTargetUnexpectedFile target <- problems ] of       []     -> return ()-      target -> die+      target -> die' verbosity               $ unlines                   [ "Unrecognised file target '" ++ name ++ "'."                   | name <- target ]@@ -346,7 +350,7 @@      case [ target | UserTargetUnexpectedUriScheme target <- problems ] of       []     -> return ()-      target -> die+      target -> die' verbosity               $ unlines                   [ "URL target not supported '" ++ name ++ "'."                   | name <- target ]@@ -354,7 +358,7 @@      case [ target | UserTargetUnrecognisedUri target <- problems ] of       []     -> return ()-      target -> die+      target -> die' verbosity               $ unlines                   [ "Unrecognise URL target '" ++ name ++ "'."                   | name <- target ]@@ -374,14 +378,14 @@                    -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]-                   -> IO [PackageSpecifier SourcePackage]+                   -> 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 <- mapM (readPackageTarget verbosity)                   =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat-                  =<< mapM (expandUserTarget worldFile) userTargets+                  =<< mapM (expandUserTarget verbosity worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must     -- disambiguate named package references@@ -405,13 +409,13 @@ -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg =-     PackageTargetNamed      PackageName [PackageConstraint] UserTarget+     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 [PackageConstraint] UserTarget+   | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget    | PackageTargetLocation pkg-  deriving Show+  deriving (Show, Functor, Foldable, Traversable)   -- ------------------------------------------------------------@@ -421,32 +425,33 @@ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). ---expandUserTarget :: FilePath+expandUserTarget :: Verbosity+                 -> FilePath                  -> UserTarget                  -> IO [PackageTarget (PackageLocation ())]-expandUserTarget worldFile userTarget = case userTarget of+expandUserTarget verbosity worldFile userTarget = case userTarget of      UserTargetNamed (Dependency name vrange) ->-      let constraints = [ PackageConstraintVersion name vrange-                        | not (isAnyVersion vrange) ]-      in  return [PackageTargetNamedFuzzy name constraints userTarget]+      let props = [ PackagePropertyVersion vrange+                  | not (isAnyVersion vrange) ]+      in  return [PackageTargetNamedFuzzy name props userTarget]      UserTargetWorld -> do-      worldPkgs <- World.getContents worldFile+      worldPkgs <- World.getContents verbosity worldFile       --TODO: should we warn if there are no world targets?-      return [ PackageTargetNamed name constraints userTarget+      return [ PackageTargetNamed name props userTarget              | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs-             , let constraints = [ PackageConstraintVersion name vrange-                                 | not (isAnyVersion vrange) ]-                              ++ [ PackageConstraintFlags name flags-                                 | not (null flags) ] ]+             , let props = [ PackagePropertyVersion vrange+                           | not (isAnyVersion vrange) ]+                        ++ [ PackagePropertyFlags flags+                           | not (null flags) ] ]      UserTargetLocalDir dir ->       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]      UserTargetLocalCabalFile file -> do       let dir = takeDirectory file-      _   <- tryFindPackageDesc dir (localPackageError dir) -- just as a check+      _   <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]      UserTargetLocalTarball tarballFile ->@@ -469,13 +474,9 @@ fetchPackageTarget :: Verbosity                    -> RepoContext                    -> PackageTarget (PackageLocation ())-                   -> IO (PackageTarget (PackageLocation FilePath))-fetchPackageTarget verbosity repoCtxt target = case target of-    PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)-    PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)-    PackageTargetLocation location  -> do-      location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location)-      return (PackageTargetLocation location')+                   -> 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.@@ -483,28 +484,21 @@ -- This only affects targets given by location, named targets are unaffected. -- readPackageTarget :: Verbosity-                  -> PackageTarget (PackageLocation FilePath)-                  -> IO (PackageTarget SourcePackage)-readPackageTarget verbosity target = case target of--    PackageTargetNamed pkgname constraints userTarget ->-      return (PackageTargetNamed pkgname constraints userTarget)--    PackageTargetNamedFuzzy pkgname constraints userTarget ->-      return (PackageTargetNamedFuzzy pkgname constraints userTarget)--    PackageTargetLocation location -> case location of+                  -> PackageTarget ResolvedPkgLoc+                  -> IO (PackageTarget UnresolvedSourcePackage)+readPackageTarget verbosity = traverse modifyLocation+  where+    modifyLocation location = case location of        LocalUnpackedPackage dir -> do-        pkg <- tryFindPackageDesc dir (localPackageError dir) >>=-                 readPackageDescription verbosity-        return $ PackageTargetLocation $-                   SourcePackage {-                     packageInfoId        = packageId pkg,-                     packageDescription   = pkg,-                     packageSource        = fmap Just location,-                     packageDescrOverride = Nothing-                   }+        pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=+                 readGenericPackageDescription verbosity+        return $ SourcePackage {+                   packageInfoId        = packageId pkg,+                   packageDescription   = pkg,+                   packageSource        = fmap Just location,+                   packageDescrOverride = Nothing+                 }        LocalTarballPackage tarballFile ->         readTarballPackageTarget location tarballFile tarballFile@@ -516,26 +510,24 @@         error "TODO: readPackageTarget RepoTarballPackage"         -- For repo tarballs this info should be obtained from the index. -  where     readTarballPackageTarget location tarballFile tarballOriginalLoc = do       (filename, content) <- extractTarballPackageCabalFile                                tarballFile tarballOriginalLoc       case parsePackageDescription' content of-        Nothing  -> die $ "Could not parse the cabal file "+        Nothing  -> die' verbosity $ "Could not parse the cabal file "                        ++ filename ++ " in " ++ tarballFile         Just pkg ->-          return $ PackageTargetLocation $-                     SourcePackage {-                       packageInfoId        = packageId pkg,-                       packageDescription   = pkg,-                       packageSource        = fmap Just location,-                       packageDescrOverride = Nothing-                     }+          return $ SourcePackage {+                     packageInfoId        = packageId pkg,+                     packageDescription   = pkg,+                     packageSource        = fmap Just location,+                     packageDescrOverride = Nothing+                   }      extractTarballPackageCabalFile :: FilePath -> String                                    -> IO (FilePath, BS.ByteString)     extractTarballPackageCabalFile tarballFile tarballOriginalLoc =-          either (die . formatErr) return+          either (die' verbosity . formatErr) return         . check         . accumEntryMap         . Tar.filterEntries isCabalFile@@ -566,11 +558,15 @@           _                 -> False      parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription+#ifdef CABAL_PARSEC+    parsePackageDescription' bs = +        parseGenericPackageDescriptionMaybe (BS.toStrict bs)+#else     parsePackageDescription' content =-      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of+      case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ pkg -> Just pkg         _             -> Nothing-+#endif  -- ------------------------------------------------------------ -- * Checking package targets@@ -597,20 +593,18 @@     disambiguatePackageTarget packageTarget = case packageTarget of       PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) -      PackageTargetNamed pkgname constraints userTarget+      PackageTargetNamed pkgname props userTarget         | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)                     -> Left (PackageNameUnknown pkgname userTarget)-        | otherwise -> Right (NamedPackage pkgname constraints)+        | otherwise -> Right (NamedPackage pkgname props) -      PackageTargetNamedFuzzy pkgname constraints userTarget ->+      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' constraints')-            where-              constraints' = map (renamePackageConstraint pkgname') constraints+          Unambiguous pkgname' -> Right (NamedPackage pkgname' props)      -- use any extra specific available packages to help us disambiguate     packageNameEnv :: PackageNameEnv@@ -626,7 +620,7 @@     case [ pkg | PackageNameUnknown pkg originalTarget <- problems                , not (isUserTagetWorld originalTarget) ] of       []    -> return ()-      pkgs  -> die $ unlines+      pkgs  -> die' verbosity $ unlines                        [ "There is no package named '" ++ display name ++ "'. "                        | name <- pkgs ]                   ++ "You may need to run 'cabal update' to get the latest "@@ -634,7 +628,7 @@      case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of       []          -> return ()-      ambiguities -> die $ unlines+      ambiguities -> die' verbosity $ unlines                              [    "The package name '" ++ display name                                ++ "' is ambiguous. It could be: "                                ++ intercalate ", " (map display matches)@@ -679,66 +673,91 @@  instance Monoid PackageNameEnv where   mempty = PackageNameEnv (const [])-  mappend = (Semi.<>)+  mappend = (<>) -instance Semi.Semigroup PackageNameEnv where+instance Semigroup PackageNameEnv where   PackageNameEnv lookupA <> PackageNameEnv lookupB =     PackageNameEnv (\name -> lookupA name ++ lookupB name)  indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup   where-    pkgNameLookup (PackageName name) =-      map fst (PackageIndex.searchByName pkgIndex name)+    pkgNameLookup pname =+      map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname)  extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup   where-    pkgNameLookup (PackageName name) =-      [ PackageName name'-      | let lname = lowercase name-      , PackageName name' <- names-      , lowercase name' == lname ]+    pkgNameLookup pname =+      [ pname'+      | let lname = lowercase (unPackageName pname)+      , pname' <- names+      , lowercase (unPackageName pname') == lname ]   -- ------------------------------------------------------------ -- * Package constraints -- ------------------------------------------------------------ -data UserConstraint =-     UserConstraintVersion   PackageName VersionRange-   | UserConstraintInstalled PackageName-   | UserConstraintSource    PackageName-   | UserConstraintFlags     PackageName FlagAssignment-   | UserConstraintStanzas   PackageName [OptionalStanza]+-- | 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++-- | 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++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  userConstraintPackageName :: UserConstraint -> PackageName-userConstraintPackageName uc = case uc of-  UserConstraintVersion   name _ -> name-  UserConstraintInstalled name   -> name-  UserConstraintSource    name   -> name-  UserConstraintFlags     name _ -> name-  UserConstraintStanzas   name _ -> name+userConstraintPackageName (UserConstraint scope _) = scopePN scope+  where+    scopePN (UserQualified _ pn) = pn+    scopePN (UserAnyQualifier pn) = pn+    scopePN (UserAnySetupQualifier pn) = pn  userToPackageConstraint :: UserConstraint -> PackageConstraint--- At the moment, the types happen to be directly equivalent-userToPackageConstraint uc = case uc of-  UserConstraintVersion   name ver   -> PackageConstraintVersion    name ver-  UserConstraintInstalled name       -> PackageConstraintInstalled  name-  UserConstraintSource    name       -> PackageConstraintSource     name-  UserConstraintFlags     name flags -> PackageConstraintFlags      name flags-  UserConstraintStanzas   name stanzas -> PackageConstraintStanzas  name stanzas--renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint-renamePackageConstraint name pc = case pc of-  PackageConstraintVersion   _ ver   -> PackageConstraintVersion    name ver-  PackageConstraintInstalled _       -> PackageConstraintInstalled  name-  PackageConstraintSource    _       -> PackageConstraintSource     name-  PackageConstraintFlags     _ flags -> PackageConstraintFlags      name flags-  PackageConstraintStanzas   _ stanzas -> PackageConstraintStanzas   name stanzas+userToPackageConstraint (UserConstraint scope prop) =+  PackageConstraint (fromUserConstraintScope scope) prop  readUserConstraint :: String -> Either String UserConstraint readUserConstraint str =@@ -747,72 +766,64 @@       Just c  -> Right c   where     msgCannotParse =-         "expected a package name followed by a constraint, which is "-      ++ "either a version range, 'installed', 'source' or flags"+         "expected a (possibly qualified) package name followed by a " +++         "constraint, which is either a version range, 'installed', " +++         "'source', 'test', 'bench', or flags"  instance Text UserConstraint where-  disp (UserConstraintVersion   pkgname verrange) = disp pkgname-                                                    <+> disp verrange-  disp (UserConstraintInstalled pkgname)          = disp pkgname-                                                    <+> Disp.text "installed"-  disp (UserConstraintSource    pkgname)          = disp pkgname-                                                    <+> Disp.text "source"-  disp (UserConstraintFlags     pkgname flags)    = disp pkgname-                                                    <+> dispFlagAssignment flags-  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname-                                                    <+> dispStanzas stanzas-    where-      dispStanzas = Disp.hsep . map dispStanza-      dispStanza TestStanzas  = Disp.text "test"-      dispStanza BenchStanzas = Disp.text "bench"--  parse = parse >>= parseConstraint-    where-      parseConstraint pkgname =-            ((parse >>= return . UserConstraintVersion pkgname)-        +++ (do skipSpaces1-                _ <- Parse.string "installed"-                return (UserConstraintInstalled pkgname))-        +++ (do skipSpaces1-                _ <- Parse.string "source"-                return (UserConstraintSource pkgname))-        +++ (do skipSpaces1-                _ <- Parse.string "test"-                return (UserConstraintStanzas pkgname [TestStanzas]))-        +++ (do skipSpaces1-                _ <- Parse.string "bench"-                return (UserConstraintStanzas pkgname [BenchStanzas])))-        <++ (do skipSpaces1-                flags <- parseFlagAssignment-                return (UserConstraintFlags pkgname flags))----TODO: [code cleanup] move these somewhere else-dispFlagAssignment :: FlagAssignment -> Disp.Doc-dispFlagAssignment = Disp.hsep . map dispFlagValue-  where-    dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f-    dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f-    dispFlagName (FlagName f) = Disp.text f--parseFlagAssignment :: Parse.ReadP r FlagAssignment-parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1-  where-    parseFlagValue =-          (do Parse.optional (Parse.char '+')-              f <- parseFlagName-              return (f, True))-      +++ (do _ <- Parse.char '-'-              f <- parseFlagName-              return (f, False))-    parseFlagName = liftM (FlagName . lowercase) ident--    ident :: Parse.ReadP r String-    ident = Parse.munch1 identChar >>= \s -> check s >> return s-      where-        identChar c   = isAlphaNum c || c == '_' || c == '-'-        check ('-':_) = Parse.pfail-        check _       = return ()--skipSpaces1 :: Parse.ReadP r ()-skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces+  disp (UserConstraint scope prop) =+    dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop+  +  parse =+    let parseConstraintScope :: Parse.ReadP a UserConstraintScope+        parseConstraintScope =+          do+             _ <- Parse.string "any."+             pn <- parse+             return (UserAnyQualifier pn)+          ++++          do+             _ <- Parse.string "setup."+             pn <- parse+             return (UserAnySetupQualifier pn)+          ++++          do+             -- Qualified name+             pn <- parse+             (return (UserQualified UserQualToplevel pn)+              ++++              do _ <- Parse.string ":setup."+                 pn2 <- parse+                 return (UserQualified (UserQualSetup pn) pn2)) +              -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax.+              --+              -- ++++              -- do _ <- Parse.string ":"+              --    pn2 <- parse+              --    _ <- Parse.string ":exe."+              --    pn3 <- parse+              --    return (UserQualExe pn pn2, pn3)+    in do+      scope <- parseConstraintScope+                       +      -- Package property+      let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x+      prop <- ((parse >>= return . PackagePropertyVersion)+               ++++               keyword "installed" PackagePropertyInstalled+               ++++               keyword "source" PackagePropertySource+               ++++               keyword "test" (PackagePropertyStanzas [TestStanzas])+               ++++               keyword "bench" (PackagePropertyStanzas [BenchStanzas]))+              -- Note: the parser is left-biased here so that we+              -- don't get an ambiguous parse from 'installed',+              -- 'source', etc. being regarded as flags.+              <+++              (Parse.skipSpaces1 >> parseFlagAssignment+               >>= return . PackagePropertyFlags)+    +      -- Result+      return (UserConstraint scope prop)
Distribution/Client/Types.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -19,30 +21,44 @@ module Distribution.Client.Types where  import Distribution.Package-         ( PackageName, PackageId, Package(..)-         , UnitId(..), mkUnitId-         , HasUnitId(..), PackageInstalled(..) )+         ( Package(..), HasMungedPackageId(..), HasUnitId(..)+         , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )+         ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription-         ( Benchmark(..), GenericPackageDescription(..), FlagAssignment-         , TestSuite(..) )-import Distribution.PackageDescription.Configuration-         ( mapTreeData )-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Client.ComponentDeps-         ( ComponentDeps )-import qualified Distribution.Client.ComponentDeps as CD+         ( FlagAssignment ) import Distribution.Version          ( VersionRange )-import Distribution.Text (display)+import Distribution.Types.ComponentId+         ( ComponentId )+import Distribution.Types.MungedPackageId+         ( computeCompatPackageId )+import Distribution.Types.PackageId+         ( PackageId )+import Distribution.Types.AnnotatedId+import Distribution.Types.UnitId+         ( UnitId )+import Distribution.Types.PackageName+         ( PackageName )+import Distribution.Types.ComponentName+         ( ComponentName(..) ) +import Distribution.Solver.Types.PackageIndex+         ( PackageIndex )+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Solver.Types.ComponentDeps+         ( ComponentDeps )+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageFixedDeps+import Distribution.Solver.Types.SourcePackage+import Distribution.Compat.Graph (IsNode(..))+import Distribution.Simple.Utils (ordNub)+ import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI)-import Data.ByteString.Lazy (ByteString) import Control.Exception-         ( SomeException )+         ( Exception, SomeException )+import Data.Typeable (Typeable) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) @@ -53,7 +69,7 @@ -- | This is the information we get from a @00-index.tar.gz@ hackage index. -- data SourcePackageDb = SourcePackageDb {-  packageIndex       :: PackageIndex SourcePackage,+  packageIndex       :: PackageIndex UnresolvedSourcePackage,   packagePreferences :: Map PackageName VersionRange }   deriving (Eq, Generic)@@ -75,160 +91,131 @@ -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler. ---type InstalledPackageId = UnitId--installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId-installedPackageId = installedUnitId---- | 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 = CD.fromInstalled . installedDepends+type InstalledPackageId = ComponentId  --- | In order to reuse the implementation of PackageIndex which relies on--- 'UnitId', we need to be able to synthesize these IDs prior--- to installation.  Eventually, we'll move to a representation of--- 'UnitId' which can be properly computed before compilation--- (of course, it's a bit of a misnomer since the packages are not actually--- installed yet.)  In any case, we'll synthesize temporary installed package--- IDs to use as keys during install planning.  These should never be written--- out!  Additionally, they need to be guaranteed unique within the install--- plan.-fakeUnitId :: PackageId -> UnitId-fakeUnitId = mkUnitId . (".fake."++) . display- -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the -- final configure process will be independent of the environment. ---data ConfiguredPackage = ConfiguredPackage-       SourcePackage       -- package info, including repo-       FlagAssignment      -- complete flag assignment for the package-       [OptionalStanza]    -- list of enabled optional stanzas for the package-       (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.+-- 'ConfiguredPackage' is assumed to not support Backpack.  Only the+-- @new-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 :: 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) -instance Binary ConfiguredPackage+-- | '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) (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)++ -- | A ConfiguredId is a package ID for a configured package. ----- Once we configure a source package we know it's UnitId--- (at least, in principle, even if we have to fake it currently). It is still+-- Once we configure a source package we know it's 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 it's -- configuration parameters and dependencies have been specified).------ TODO: I wonder if it would make sense to promote this datatype to Cabal--- and use it consistently instead of UnitIds? data ConfiguredId = ConfiguredId {     confSrcId  :: PackageId-  , confInstId :: UnitId+  , confCompName :: Maybe ComponentName+  , confInstId :: ComponentId   }-  deriving (Eq, Generic)+  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 Show ConfiguredId where-  show = show . confSrcId+  show cid = show (confInstId cid)  instance Package ConfiguredId where   packageId = confSrcId -instance HasUnitId ConfiguredId where-  installedUnitId = confInstId--instance Package ConfiguredPackage where-  packageId (ConfiguredPackage pkg _ _ _) = packageId pkg--instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps--instance HasUnitId ConfiguredPackage where-  installedUnitId = fakeUnitId . packageId---- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be--- installed already, hence itself ready to be installed.-data GenericReadyPackage srcpkg ipkg-   = ReadyPackage-       srcpkg                  -- see 'ConfiguredPackage'.-       (ComponentDeps [ipkg])  -- Installed dependencies.-  deriving (Eq, Show, Generic)--type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo--instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where-  packageId (ReadyPackage srcpkg _deps) = packageId srcpkg--instance (Package srcpkg, HasUnitId ipkg) =>-         PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where-  depends (ReadyPackage _ deps) = fmap (map installedUnitId) deps--instance HasUnitId srcpkg =>-         HasUnitId (GenericReadyPackage srcpkg ipkg) where-  installedUnitId (ReadyPackage pkg _) = installedUnitId pkg+instance Package (ConfiguredPackage loc) where+  packageId cpkg = packageId (confPkgSource cpkg) -instance (Binary srcpkg, Binary ipkg) => Binary (GenericReadyPackage srcpkg ipkg)+instance HasMungedPackageId (ConfiguredPackage loc) where+  mungedId cpkg = computeCompatPackageId (packageId cpkg) Nothing +-- Never has nontrivial UnitId+instance HasUnitId (ConfiguredPackage loc) where+  installedUnitId = newSimpleUnitId . confPkgId --- | A package description along with the location of the package sources.----data SourcePackage = SourcePackage {-    packageInfoId        :: PackageId,-    packageDescription   :: GenericPackageDescription,-    packageSource        :: PackageLocation (Maybe FilePath),-    packageDescrOverride :: PackageDescriptionOverride-  }-  deriving (Eq, Show, Generic)+instance PackageInstalled (ConfiguredPackage loc) where+  installedDepends = CD.flatDeps . depends -instance Binary SourcePackage+class HasConfiguredId a where+    configuredId :: a -> ConfiguredId --- | We sometimes need to override the .cabal file in the tarball with--- the newer one from the package index.-type PackageDescriptionOverride = Maybe ByteString+-- 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) -instance Package SourcePackage where packageId = packageInfoId+-- | 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) -data OptionalStanza-    = TestStanzas-    | BenchStanzas-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)+-- 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 -instance Binary OptionalStanza+type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -enableStanzas-    :: [OptionalStanza]-    -> GenericPackageDescription-    -> GenericPackageDescription-enableStanzas stanzas gpkg = gpkg-    { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg-    , condTestSuites = flagTests $ condTestSuites gpkg-    }-  where-    enableTest t = t { testEnabled = TestStanzas `elem` stanzas }-    enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas }-    flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))-    flagTests = map (\(n, t) -> (n, mapTreeData enableTest t))+-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.+type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc  -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ +type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)++type ResolvedPkgLoc = PackageLocation FilePath+ data PackageLocation local =      -- | An unpacked package in the given dir, or current dir@@ -249,7 +236,7 @@ --TODO: --  * add support for darcs and other SCM style remote repos with a local cache --  | ScmPackage-  deriving (Show, Functor, Eq, Ord, Generic)+  deriving (Show, Functor, Eq, Ord, Generic, Typeable)  instance Binary local => Binary (PackageLocation local) @@ -341,7 +328,14 @@ -- * Build results -- ------------------------------------------------------------ -type BuildResult  = Either BuildFailure BuildSuccess+-- | 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@@ -350,18 +344,25 @@                   | BuildFailed     SomeException                   | TestsFailed     SomeException                   | InstallFailed   SomeException-  deriving (Show, Generic)-data BuildSuccess = BuildOk         DocsResult TestsResult-                                    (Maybe InstalledPackageInfo)+  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)+  deriving (Show, Generic, Typeable) data TestsResult = TestsNotTried | TestsOk-  deriving (Show, Generic)+  deriving (Show, Generic, Typeable)  instance Binary BuildFailure-instance Binary BuildSuccess+instance Binary BuildResult instance Binary DocsResult instance Binary TestsResult
Distribution/Client/Update.hs view
@@ -47,7 +47,6 @@   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file." update verbosity repoCtxt = do-  jobCtrl <- newParallelJobControl   let repos       = repoContextRepos repoCtxt       remoteRepos = catMaybes (map maybeRepoRemote repos)   case remoteRepos of@@ -58,6 +57,7 @@     _ -> notice verbosity . unlines             $ "Downloading the latest package lists from: "             : map (("- " ++) . remoteRepoName) remoteRepos+  jobCtrl <- newParallelJobControl (length repos)   mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos   mapM_ (\_ -> collectJob jobCtrl) repos
Distribution/Client/Upload.hs view
@@ -1,13 +1,13 @@-module Distribution.Client.Upload (check, upload, uploadDoc, report) where+module Distribution.Client.Upload (upload, uploadDoc, report) where  import Distribution.Client.Types ( Username(..), Password(..)                                  , RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils          ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup-         ( RepoContext(..) )+         ( IsCandidate(..), RepoContext(..) ) -import Distribution.Simple.Utils (notice, warn, info, die)+import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config@@ -15,69 +15,99 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.URI (URI(uriPath), parseURI)+import Network.URI (URI(uriPath)) import Network.HTTP (Header(..), HeaderName(..)) -import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho)+import System.IO        (hFlush, stdout)+import System.IO.Echo   (withoutInputEcho) import System.Exit      (exitFailure)-import Control.Exception (bracket)-import System.FilePath  ((</>), takeExtension, takeFileName)+import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory-import Control.Monad (forM_, when)+import Control.Monad (forM_, when, foldM) import Data.Maybe (catMaybes)+import Data.Char (isSpace)  type Auth = Maybe (String, String) -checkURI :: URI-Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/"-                           ++ "hackage-scripts/check-pkg"+-- > 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 -> [FilePath]+       -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]        -> IO ()-upload verbosity repoCtxt mUsername mPassword paths = do+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 "Cannot upload. No remote repositories are configured."-        rs -> remoteRepoTryUpgradeToHttps transport (last rs)+        [] -> die' verbosity "Cannot upload. No remote repositories are configured."+        rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs)     let targetRepoURI = remoteRepoURI targetRepo         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.</> "upload"+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                  IsCandidate -> "/candidate"+                  IsPublished -> ""+              ]         }     Username username <- maybe promptUsername return mUsername     Password password <- maybe promptPassword return mPassword     let auth = Just (username,password)     forM_ paths $ \path -> do       notice verbosity $ "Uploading " ++ path ++ "... "-      handlePackage transport verbosity uploadURI auth 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 -> FilePath+          -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath           -> IO ()-uploadDoc verbosity repoCtxt mUsername mPassword path = do+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 $ "Cannot upload. No remote repositories are configured."-        rs -> remoteRepoTryUpgradeToHttps transport (last rs)+        [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."+        rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs)     let targetRepoURI = remoteRepoURI targetRepo         rootIfEmpty x = if null x then "/" else x         uploadURI = targetRepoURI {             uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> "package/" ++ pkgid ++ "/docs"+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                IsCandidate -> "/candidate"+                IsPublished -> ""+              , "/docs"+              ]         }         (reverseSuffix, reversePkgid) = break (== '-')                                         (reverse (takeFileName path))         pkgid = reverse $ tail reversePkgid     when (reverse reverseSuffix /= "docs.tar.gz"           || null reversePkgid || head reversePkgid /= '-') $-      die "Expected a file name matching the pattern <pkgid>-docs.tar.gz"+      die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"     Username username <- maybe promptUsername return mUsername     Password password <- maybe promptPassword return mPassword @@ -89,7 +119,9 @@     notice verbosity $ "Uploading documentation " ++ path ++ "... "     resp <- putHttpFile transport verbosity uploadURI path auth headers     case resp of-      (200,_)     ->+      -- Hackage responds with 204 No Content when docs are uploaded+      -- successfully.+      (code,_) | code `elem` [200,204] -> do         notice verbosity "Ok"       (code,err)  -> do         notice verbosity $ "Error uploading documentation "@@ -108,10 +140,8 @@ promptPassword = do   putStr "Hackage password: "   hFlush stdout-  -- save/restore the terminal echoing status-  passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do-    hSetEcho stdin False  -- no echoing for entering the password-    fmap Password getLine+  -- save/restore the terminal echoing status (no echoing for entering the password)+  passwd <- withoutInputEcho $ fmap Password getLine   putStrLn ""   return passwd @@ -132,7 +162,7 @@            contents <- getDirectoryContents srcDir            forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->              do inp <- readFile (srcDir </> logFile)-                let (reportStr, buildLog) = read inp :: (String,String)+                let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse                 case BuildReport.parse reportStr of                   Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME                   Right report' ->@@ -142,22 +172,32 @@                          (remoteRepoURI remoteRepo) [(report', Just buildLog)]                        return () -check :: Verbosity -> RepoContext -> [FilePath] -> IO ()-check verbosity repoCtxt paths = do-    transport <- repoContextGetTransport repoCtxt-    forM_ paths $ \path -> do-      notice verbosity $ "Checking " ++ path ++ "... "-      handlePackage transport verbosity checkURI Nothing path--handlePackage :: HttpTransport -> Verbosity -> URI -> Auth-              -> FilePath -> IO ()-handlePackage transport verbosity uri auth path =+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-       (200,_)     ->-          notice verbosity "Ok"+       (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 view
@@ -3,12 +3,14 @@ module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy                                  , readMaybe-                                 , inDir, logDirChange+                                 , inDir, withEnv, logDirChange+                                 , withExtraPathEnv                                  , determineNumJobs, numberOfProcessors                                  , removeExistingFile                                  , withTempFileName                                  , makeAbsoluteToCwd                                  , makeRelativeToCwd, makeRelativeToDir+                                 , makeRelativeCanonical                                  , filePathToByteString                                  , byteStringToFilePath, tryCanonicalizePath                                  , canonicalizePathNoThrow@@ -18,36 +20,27 @@                                  , relaxEncodingErrors)        where +import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Compat.Environment import Distribution.Compat.Exception   ( catchIO )-import Distribution.Client.Compat.Time ( getModTime )+import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup       ( Flag(..) )-import Distribution.Simple.Utils       ( die, findPackageDesc )+import Distribution.Verbosity+import Distribution.Simple.Utils       ( die', findPackageDesc ) import qualified Data.ByteString.Lazy as BS-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad-         ( when ) import Data.Bits          ( (.|.), shiftL, shiftR )-import Data.Char-         ( ord, chr )-#if MIN_VERSION_base(4,6,0)-import Text.Read-         ( readMaybe )-#endif+import System.FilePath import Data.List-         ( isPrefixOf, sortBy, groupBy )-import Data.Word-         ( Word8, Word32)+         ( groupBy ) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception          ( finally, bracket ) import System.Directory          ( canonicalizePath, doesFileExist, getCurrentDirectory          , removeFile, setCurrentDirectory )-import System.FilePath-         ( (</>), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO          ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0)@@ -64,16 +57,12 @@ #endif  #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-import Prelude hiding (ioError)-import Control.Monad (liftM2, unless)-import System.Directory (doesDirectoryExist)-import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)+import qualified System.Directory as Dir+import qualified System.IO.Error as IOError #endif  -- | Generic merging utility. For sorted input lists this is a full outer join. ----- * The result list never contains @(Nothing, Nothing)@.--- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] mergeBy cmp = merge   where@@ -99,14 +88,6 @@     moreThanOne (_:_:_) = True     moreThanOne _       = False -#if !MIN_VERSION_base(4,6,0)--- | An implementation of readMaybe, for compatability with older base versions.-readMaybe :: Read a => String -> Maybe a-readMaybe s = case reads s of-                [(x,"")] -> Just x-                _        -> Nothing-#endif- -- | Like 'removeFile', but does not throw an exception when the file does not -- exist. removeExistingFile :: FilePath -> IO ()@@ -129,6 +110,9 @@     (\(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@@ -136,6 +120,36 @@   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, 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@@ -231,9 +245,9 @@ tryCanonicalizePath path = do   ret <- canonicalizePath path #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)+  exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)   unless exists $-    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"+    IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"                         Nothing (Just ret) #endif   return ret@@ -285,17 +299,17 @@       return ()  -- |Like 'tryFindPackageDesc', but with error specific to add-source deps.-tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath-tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $+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 :: FilePath -> String -> IO FilePath-tryFindPackageDesc depPath err = do+tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath+tryFindPackageDesc verbosity depPath err = do     errOrCabalFile <- findPackageDesc depPath     case errOrCabalFile of         Right file -> return file-        Left _ -> die err+        Left _ -> die' verbosity err
+ Distribution/Client/Utils/Assertion.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE CPP #-}+module Distribution.Client.Utils.Assertion (expensiveAssert) where++#ifdef DEBUG_EXPENSIVE_ASSERTIONS+import Control.Exception (assert)+import Distribution.Compat.Stack+#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/LabeledGraph.hs 
@@ -1,116 +0,0 @@--- | Wrapper around Data.Graph with support for edge labels-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Client.Utils.LabeledGraph (-    -- * Graphs-    Graph-  , Vertex-    -- ** Building graphs-  , graphFromEdges-  , graphFromEdges'-  , buildG-  , transposeG-    -- ** Graph properties-  , vertices-  , edges-    -- ** Operations on the underlying unlabeled graph-  , forgetLabels-  , topSort-  ) where--import Data.Array-import Data.Graph (Vertex, Bounds)-import Data.List (sortBy)-import Data.Maybe (mapMaybe)-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       = zipWith (,) [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/Client/Win32SelfUpgrade.hs view
@@ -42,7 +42,7 @@     deleteOldExeFile,   ) where -#if mingw32_HOST_OS+#ifdef mingw32_HOST_OS  import qualified System.Win32 as Win32 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)@@ -212,7 +212,7 @@ #else  import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die)+import Distribution.Simple.Utils (die')  possibleSelfUpgrade :: Verbosity                     -> [FilePath]@@ -220,6 +220,6 @@ possibleSelfUpgrade _ _ action = action  deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()-deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"+deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32"  #endif
Distribution/Client/World.hs view
@@ -29,14 +29,13 @@     getContents,   ) where -import Distribution.Package-         ( Dependency(..) )+import Distribution.Types.Dependency import Distribution.PackageDescription-         ( FlagAssignment, FlagName(FlagName) )+         ( FlagAssignment, mkFlagName, unFlagName ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Simple.Utils-         ( die, info, chattyTry, writeFileAtomic )+         ( die', info, chattyTry, writeFileAtomic ) import Distribution.Text          ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse@@ -91,7 +90,7 @@ modifyWorld _ _         _     []   = return () modifyWorld f verbosity world pkgs =   chattyTry "Error while updating world-file. " $ do-    pkgsOldWorld <- getContents world+    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@@ -107,12 +106,12 @@   -- | Returns the content of the world file as a list-getContents :: FilePath -> IO [WorldPkgInfo]-getContents world = do+getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]+getContents verbosity world = do   content <- safelyReadFile world   let result = map simpleParse (lines $ B.unpack content)   case sequence result of-    Nothing -> die "Could not parse world file."+    Nothing -> die' verbosity "Could not parse world file."     Just xs -> return xs   where   safelyReadFile :: FilePath -> IO B.ByteString@@ -128,10 +127,10 @@       dispFlags [] = Disp.empty       dispFlags fs = Disp.text "--flags="                   <> Disp.doubleQuotes (flagAssToDoc fs)-      flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->+      flagAssToDoc = foldr (\(fname,val) flagAssDoc ->                              (if not val then Disp.char '-'                                          else Disp.empty)-                             Disp.<> Disp.text fname+                             Disp.<> Disp.text (unFlagName fname)                              Disp.<+> flagAssDoc)                            Disp.empty   parse = do@@ -156,7 +155,7 @@             val <- negative Parse.+++ positive             name <- ident             Parse.skipSpaces-            return (FlagName name,val)+            return (mkFlagName name,val)           negative = do             _ <- Parse.char '-'             return False
+ Distribution/Solver/Modular.hs view
@@ -0,0 +1,60 @@+module Distribution.Solver.Modular+         ( modularResolver, SolverConfig(..)) 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 Data.Map as M+         ( fromListWith )+import Distribution.Compat.Graph+         ( IsNode(..) )+import Distribution.Solver.Modular.Assignment+         ( toCPs )+import Distribution.Solver.Modular.ConfiguredConversion+         ( convCP )+import Distribution.Solver.Modular.IndexConversion+         ( convPIs )+import Distribution.Solver.Modular.Log+         ( logToProgress )+import Distribution.Solver.Modular.Package+         ( PN )+import Distribution.Solver.Modular.Solver+         ( SolverConfig(..), solve )+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.DependencyResolver+import Distribution.System+         ( Platform(..) )+import Distribution.Simple.Utils+         ( ordNubBy )+++-- | 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+  logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format+  solve sc cinfo idx pkgConfigDB pprefs gcs pns+    where+      -- Indices have to be converted into solver-specific uniform index.+      idx    = convPIs os arch cinfo (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
+ Distribution/Solver/Modular/Assignment.hs view
@@ -0,0 +1,152 @@+module Distribution.Solver.Modular.Assignment+    ( Assignment(..)+    , FAssignment+    , SAssignment+    , PreAssignment(..)+    , extend+    , toCPs+    ) where++import Control.Applicative+import Control.Monad+import Data.Array as A+import Data.List as L+import Data.Map as M+import Data.Maybe+import Prelude hiding (pi)++import Language.Haskell.Extension (Extension, Language)++import Distribution.PackageDescription (FlagAssignment) -- 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+import Distribution.Solver.Modular.Version++-- | A (partial) package assignment. Qualified package names+-- are associated with instances.+type PAssignment    = Map QPN I++-- | A (partial) package preassignment. Qualified package names+-- are associated with constrained instances. Constrained instances+-- record constraints about the instances that can still be chosen,+-- and in the extreme case fix a concrete instance.+type PPreAssignment = Map QPN (CI QPN)+type FAssignment    = Map QFN Bool+type SAssignment    = Map QSN Bool++-- | A (partial) assignment of variables.+data Assignment = A PAssignment FAssignment SAssignment+  deriving (Show, Eq)++-- | A preassignment comprises knowledge about variables, but not+-- necessarily fixed values.+data PreAssignment = PA PPreAssignment FAssignment SAssignment++-- | 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 -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable+       -> Var QPN+       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet, [Dep QPN]) PPreAssignment+extend extSupported langSupported pkgPresent var = foldM extendSingle+  where++    extendSingle :: PPreAssignment -> Dep QPN+                 -> Either (ConflictSet, [Dep QPN]) PPreAssignment+    extendSingle a (Ext  ext )  =+      if extSupported  ext  then Right a+                            else Left (varToConflictSet var, [Ext ext])+    extendSingle a (Lang lang)  =+      if langSupported lang then Right a+                            else Left (varToConflictSet var, [Lang lang])+    extendSingle a (Pkg pn vr)  =+      if pkgPresent pn vr then Right a+                          else Left (varToConflictSet var, [Pkg pn vr])+    extendSingle a (Dep is_exe qpn ci) =+      let ci' = M.findWithDefault (Constrained []) qpn a+      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of+            Left (c, (d, d')) -> Left  (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d'))+            Right x           -> Right x++    -- We're trying to remove trivial elements of the conflict. If we're just+    -- making a choice pkg == instance, and pkg => pkg == instance is a part+    -- of the conflict, then this info is clear from the context and does not+    -- have to be repeated.+    simplify v (Fixed _ var') c | v == var && var' == var = [c]+    simplify v c (Fixed _ var') | v == var && var' == var = [c]+    simplify _ c              d                           = [c, d]++-- | 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 (++) $+           L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $+           M.toList $+           fa+    -- Stanzas per package.+    sapp :: Map QPN [OptionalStanza]+    sapp = M.fromListWith (++) $+           L.map (\ ((SN (PI 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)+                   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 [] qpn fapp)+                                 (M.findWithDefault [] qpn sapp)+                                 (depp' qpn))+          ps
+ Distribution/Solver/Modular/Builder.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Builder (buildTree) 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 Data.List as L+import Data.Map as M+import Prelude hiding (sequence, mapM)++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.PSQ (PSQ)+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 (Component)+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  :: PSQ (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 = 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 -> [OpenGoal Component] -> BuildState -> BuildState+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs+  where+    go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState+    go g o []                                               = s { rdeps = g, open = o }+    go g o (ng@(OpenGoal (Flagged _ _ _ _)      _gr) : ngs) = go g (cons' ng () o) ngs+      -- Note: for 'Flagged' goals, we always insert, so later additions win.+      -- This is important, because in general, if a goal is inserted twice,+      -- the later addition will have better dependency information.+    go g o (ng@(OpenGoal (Stanza  _   _  )      _gr) : ngs) = go g (cons' ng () o) ngs+    go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs)+      | qpn == qpn'       = go                            g               o  ngs+          -- we ignore self-dependencies at this point; TODO: more care may be needed+      | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs+      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs+          -- code above is correct; insert/adjust have different arg order+    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs++    cons' = P.cons . forgetCompOpenGoal++    addIfAbsent :: Eq a => a -> [a] -> [a]+    addIfAbsent x xs = if x `elem` xs then xs else x : xs++-- | 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 -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->+                    BuildState -> BuildState+scopedExtendOpen qpn i gr 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 (PI qpn i) fn) b [] []) $ M.toList fdefs+    -- Combine new package and flag goals+    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)+    -- NOTE:+    --+    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially+    -- multiple times, both via the flag declaration and via dependencies.+    -- The order is potentially important, because the occurrences via+    -- dependencies may record flag-dependency information. After a number+    -- of bugs involving computing this information incorrectly, however,+    -- we're currently not using carefully computed inter-flag dependencies+    -- anymore, but instead use 'simplifyVar' when computing conflict sets+    -- to map all flags of one package to a single flag for conflict set+    -- purposes, thereby treating them all as interdependent.+    --+    -- If we ever move to a more clever algorithm again, then the line above+    -- needs to be looked at very carefully, and probably be replaced by+    -- more systematically computed flag dependency information.++-- | Datatype that encodes what to build next+data BuildType =+    Goals                                  -- ^ build a goal choice node+  | OneGoal (OpenGoal ())                  -- ^ build a node for this goal+  | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance+  deriving Show++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 })+  | P.null gs = DoneF rdm ()+  | otherwise = GoalChoiceF rdm $ P.mapKeys close+                                $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })+                                $ P.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 { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =+  error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal"+addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =+  error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal"+addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =+  error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal"+addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =+  -- If the package does not exist in the index, we construct an emty PChoiceF node for it+  -- After all, we have no choices here. Alternatively, we could immediately construct+  -- a Fail node here, but that would complicate the construction of conflict sets.+  -- We will probably want to give this case special treatment when generating error+  -- messages though.+  case M.lookup pn idx of+    Nothing  -> PChoiceF qpn rdm gr (W.fromList [])+    Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->+                                                       ([], POption i Nothing, bs { next = Instance qpn i info gr }))+                                                     (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 (OpenGoal (Flagged qfn@(FN (PI 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 (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),+     ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) 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 (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =+  SChoiceF qsn rdm gr trivial (W.fromList+    [([0], False,                                                             bs  { next = Goals }),+     ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) 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 i (PInfo fdeps fdefs _) _gr }) =+  addChildren ((scopedExtendOpen qpn i (PDependency (PI qpn i)) 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  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)+          , next  = Goals+          , qualifyOptions = defaultQualifyOptions idx+          }+      , linkingState = M.empty+      }+  where+    -- Should a top-level goal allowed to be an executable style+    -- dependency? Well, I don't think it would make much difference+    topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal++    qpns | ind       = makeIndependent igs+         | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs
+ 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 [OptionalStanza] (ComponentDeps [PI qpn])
+ 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+        Just srcpkg = 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 view
@@ -0,0 +1,192 @@+{-# 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+  , ConflictMap+#ifdef DEBUG_CONFLICT_SETS+  , conflictSetOrigin+#endif+  , showConflictSet+  , showCSSortedByFrequency+  , showCSWithFrequency+    -- Set-like operations+  , toList+  , union+  , unions+  , insert+  , empty+  , singleton+  , member+  , filter+  , fromList+  ) where++import Prelude hiding (filter)+import Data.List (intercalate, sortBy)+import Data.Map (Map)+import Data.Set (Set)+import Data.Function (on)+import qualified Data.Set as S+import qualified Data.Map as M++#ifdef DEBUG_CONFLICT_SETS+import Data.Tree+import GHC.Stack+#endif++import Distribution.Solver.Modular.Var+import Distribution.Solver.Types.PackagePath++-- | The set of variables involved in a solver conflict+--+-- Since these variables should be preprocessed in some way, this type is+-- kept abstract.+data ConflictSet = CS {+    -- | The set of variables involved on the conflict+    conflictSetToSet :: Set (Var QPN)++#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)++instance Eq ConflictSet where+  (==) = (==) `on` conflictSetToSet++instance Ord ConflictSet where+  compare = compare `on` conflictSetToSet++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+-------------------------------------------------------------------------------}++toList :: ConflictSet -> [Var QPN]+toList = S.toList . conflictSetToSet++union ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  ConflictSet -> ConflictSet -> ConflictSet+union cs cs' = CS {+      conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet 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 {+      conflictSetToSet = S.unions (map conflictSetToSet 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 {+      conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]+#endif+    }++empty ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  ConflictSet+empty = CS {+      conflictSetToSet = S.empty+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++singleton ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Var QPN -> ConflictSet+singleton var = CS {+      conflictSetToSet = S.singleton (simplifyVar var)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++member :: Var QPN -> ConflictSet -> Bool+member var = S.member (simplifyVar var) . conflictSetToSet++filter ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  (Var QPN -> Bool) -> ConflictSet -> ConflictSet+filter p cs = CS {+      conflictSetToSet = S.filter p (conflictSetToSet cs)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]+#endif+    }++fromList ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  [Var QPN] -> ConflictSet+fromList vars = CS {+      conflictSetToSet = S.fromList (map simplifyVar vars)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++type ConflictMap = Map (Var QPN) Int+
+ Distribution/Solver/Modular/Cycles.hs view
@@ -0,0 +1,119 @@+{-# 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.Package+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 (PI qpn _) _) rdm gr w m d cs) =+        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs+    go (SChoiceF qsn@(SN (PI 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 view
@@ -0,0 +1,431 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif+module Distribution.Solver.Modular.Dependency (+    -- * Variables+    Var(..)+  , simplifyVar+  , varPI+  , showVar+    -- * Conflict sets+  , ConflictSet+  , ConflictMap+  , CS.showConflictSet+    -- * Constrained instances+  , CI(..)+  , merge+    -- * Flagged dependencies+  , FlaggedDeps+  , FlaggedDep(..)+  , Dep(..)+  , showDep+  , flattenFlaggedDeps+  , QualifyOptions(..)+  , qualifyDeps+  , unqualifyDeps+    -- ** Setting/forgetting components+  , forgetCompOpenGoal+  , setCompFlaggedDeps+    -- * Reverse dependency map+  , RevDepMap+    -- * Goals+  , Goal(..)+  , GoalReason(..)+  , QGoalReason+  , ResetVar(..)+  , goalToVar+  , goalVarToConflictSet+  , varToConflictSet+  , goalReasonToVars+    -- * Open goals+  , OpenGoal(..)+  , close+  ) where++import Prelude hiding (pi)++import Data.Map (Map)+import qualified Data.List as L++import Language.Haskell.Extension (Extension(..), Language(..))++import Distribution.Text++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++#ifdef DEBUG_CONFLICT_SETS+import GHC.Stack (CallStack)+#endif++{-------------------------------------------------------------------------------+  Constrained instances+-------------------------------------------------------------------------------}++-- | Constrained instance. If the choice has already been made, this is+-- a fixed instance, and we record the package name for which the choice+-- is for convenience. Otherwise, it is a list of version ranges paired with+-- the goals / variables that introduced them.+data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]+  deriving (Eq, Show, Functor)++showCI :: CI QPN -> String+showCI (Fixed i _)      = "==" ++ showI i+showCI (Constrained vr) = showVR (collapse vr)++-- | 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.+--+-- 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+  CI QPN -> CI QPN -> Either (ConflictSet, (CI QPN, CI QPN)) (CI QPN)+merge c@(Fixed i g1)       d@(Fixed j g2)+  | i == j                                    = Right c+  | otherwise                                 = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))+merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...+  where+    go []              = Right c+    go (d@(vr, g2) : vrs)+      | checkVR vr v   = go vrs+      | otherwise      = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d]))+merge c@(Constrained _)    d@(Fixed _ _)      = merge d c+merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))++{-------------------------------------------------------------------------------+  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.+--+-- However, top-level goals are also modelled as dependencies, but of course+-- these don't actually belong in any component of any package. Therefore, we+-- parameterize 'FlaggedDeps' and derived datatypes with a type argument that+-- specifies whether or not we have a component: we only ever instantiate this+-- type argument with @()@ for top-level goals, or 'Component' for everything+-- else (we could express this as a kind at the type-level, but that would+-- require a very recent GHC).+--+-- Note however, crucially, that independent of the type parameters, the list+-- of dependencies underneath a flag choice or stanza choices _always_ uses+-- Component as the type argument. This is important: when we pick a value for+-- a flag, we _must_ know what component the new dependencies belong to, or+-- else we don't be able to construct fine-grained reverse dependencies.+type FlaggedDeps comp qpn = [FlaggedDep comp qpn]++-- | Flagged dependencies can either be plain dependency constraints,+-- or flag-dependent dependency trees.+data FlaggedDep comp 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 for which are always enabled, for the component+    -- 'comp' (or requested for the user, if comp is @()@).+  | Simple (Dep qpn) comp+  deriving (Eq, Show)++-- | Conversatively flatten out flagged dependencies+--+-- NOTE: We do not filter out duplicates.+flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)]+flattenFlaggedDeps = concatMap aux+  where+    aux :: FlaggedDep Component qpn -> [(Dep 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 Component qpn+type FalseFlaggedDeps qpn = FlaggedDeps Component qpn++-- | Is this dependency on an executable+type IsExe = Bool++-- | A dependency (constraint) associates a package name with a+-- constrained instance.+--+-- 'Dep' 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 'Dep' ought to have two type variables.)+data Dep qpn = Dep IsExe qpn (CI qpn)  -- ^ dependency on a package (possibly for executable+             | Ext  Extension          -- ^ dependency on a language extension+             | Lang Language           -- ^ dependency on a language version+             | Pkg  PkgconfigName VR   -- ^ dependency on a pkg-config package+  deriving (Eq, Show)++showDep :: Dep QPN -> String+showDep (Dep is_exe qpn (Fixed i v)            ) =+  (if P qpn /= v then showVar v ++ " => " else "") +++  showQPN qpn +++  (if is_exe then " (exe) " else "") ++ "==" ++ showI i+showDep (Dep is_exe qpn (Constrained [(vr, v)])) =+  showVar v ++ " => " ++ showQPN qpn +++  (if is_exe then " (exe) " else "") ++ showVR vr+showDep (Dep is_exe qpn ci                     ) =+  showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci+showDep (Ext ext)   = "requires " ++ display ext+showDep (Lang lang) = "requires " ++ display lang+showDep (Pkg pn vr) = "requires pkg-config package "+                      ++ display pn ++ display vr+                      ++ ", not found in the pkg-config database"++-- | 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 Component PN -> FlaggedDeps Component QPN+qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go+  where+    go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN+    go = map go1++    go1 :: FlaggedDep Component PN -> FlaggedDep Component 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 (goD dep comp) comp++    -- Suppose package B has a setup dependency on package A.+    -- This will be recorded as something like+    --+    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])+    --+    -- 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 goal or the goal reason chain.+    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 is_exe dep ci) comp+      | is_exe      = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) (fmap (Q pp) ci)+      | qBase  dep  = Dep is_exe (Q (PackagePath ns (QualBase  pn)) dep) (fmap (Q pp) ci)+      | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) (fmap (Q pp) ci)+      | otherwise   = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) 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 comp QPN -> FlaggedDeps comp PN+unqualifyDeps = go+  where+    go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN+    go = map go1++    go1 :: FlaggedDep comp QPN -> FlaggedDep comp 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 (goD dep) comp++    goD :: Dep QPN -> Dep PN+    goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci)+    goD (Ext  ext)   = Ext ext+    goD (Lang lang)  = Lang lang+    goD (Pkg pn vr)  = Pkg pn vr++    unq :: QPN -> PN+    unq (Q _ pn) = pn++{-------------------------------------------------------------------------------+  Setting/forgetting the Component+-------------------------------------------------------------------------------}++forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()+forgetCompOpenGoal = mapCompOpenGoal $ const ()++setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn+setCompFlaggedDeps = mapCompFlaggedDeps . const++{-------------------------------------------------------------------------------+  Auxiliary: Mapping over the Component goal++  We don't export these, because the only type instantiations for 'a' and 'b'+  here should be () or Component. (We could express this at the type level+  if we relied on newer versions of GHC.)+-------------------------------------------------------------------------------}++mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b+mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr++mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn+mapCompFlaggedDeps = L.map . mapCompFlaggedDep++mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn+mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo   t f+mapCompFlaggedDep _ (Stanza  sn     t  ) = Stanza  sn       t+mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)++{-------------------------------------------------------------------------------+  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+  | PDependency (PI qpn)+  | FDependency (FN qpn) Bool+  | SDependency (SN qpn)+  deriving (Eq, Show, Functor)++type QGoalReason = GoalReason QPN++class ResetVar f where+  resetVar :: Var qpn -> f qpn -> f qpn++instance ResetVar CI where+  resetVar v (Fixed i _)       = Fixed i v+  resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs)++instance ResetVar Dep where+  resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci)+  resetVar _ (Ext ext)    = Ext ext+  resetVar _ (Lang lang)  = Lang lang+  resetVar _ (Pkg pn vr)  = Pkg pn vr++instance ResetVar Var where+  resetVar = const++goalToVar :: Goal a -> Var a+goalToVar (Goal v _) = v++-- | Compute a singleton conflict set from a goal, containing just+-- the goal variable.+--+-- NOTE: This is just a call to 'varToConflictSet' under the hood;+-- the 'GoalReason' is ignored.+goalVarToConflictSet :: Goal QPN -> ConflictSet+goalVarToConflictSet (Goal g _gr) = varToConflictSet g++-- | Compute a singleton conflict set from a 'Var'+varToConflictSet :: Var QPN -> ConflictSet+varToConflictSet = CS.singleton++-- | A goal reason is mostly just a variable paired with the+-- decision we made for that variable (except for user goals,+-- where we cannot really point to a solver variable). This+-- function drops the decision and recovers the list of+-- variables (which will be empty or contain one element).+--+goalReasonToVars :: GoalReason qpn -> [Var qpn]+goalReasonToVars UserGoal                 = []+goalReasonToVars (PDependency (PI qpn _)) = [P qpn]+goalReasonToVars (FDependency qfn _)      = [F qfn]+goalReasonToVars (SDependency qsn)        = [S qsn]++{-------------------------------------------------------------------------------+  Open goals+-------------------------------------------------------------------------------}++-- | For open goals as they occur during the build phase, we need to store+-- additional information about flags.+data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason+  deriving (Eq, Show)++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal comp -> Goal QPN+close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr+close (OpenGoal (Simple (Ext     _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Ext goal"+close (OpenGoal (Simple (Lang    _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Lang goal"+close (OpenGoal (Simple (Pkg   _ _) _) _ ) =+  error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal"+close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr+close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr++{-------------------------------------------------------------------------------+  Version ranges paired with origins+-------------------------------------------------------------------------------}++type VROrigin qpn = (VR, Var qpn)++-- | Helper function to collapse a list of version ranges with origins into+-- a single, simplified, version range.+collapse :: [VROrigin qpn] -> VR+collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR
+ Distribution/Solver/Modular/Explore.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Explore+    ( backjump+    , backjumpAndExplore+    ) where++import Data.Foldable as F+import Data.List as L (foldl')+import Data.Map as M++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Log+import Distribution.Solver.Modular.Message+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 qualified Distribution.Solver.Modular.WeightedPSQ as W+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))++-- | This function takes the variable we're currently considering, an+-- initial 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 initial 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'.+--+backjump :: EnableBackjumping -> Var QPN+         -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)+         -> ConflictMap -> ConflictSetLog a+backjump (EnableBackjumping enableBj) var initial xs =+    F.foldr combine logBackjump xs initial+  where+    combine :: forall a . (ConflictMap -> ConflictSetLog a)+            -> (ConflictSet -> ConflictMap -> ConflictSetLog a)+            ->  ConflictSet -> ConflictMap -> ConflictSetLog a+    combine x f csAcc cm = retry (x cm) next+      where+        next :: (ConflictSet, ConflictMap) -> ConflictSetLog a+        next (cs, cm')+          | enableBj && not (var `CS.member` cs) = logBackjump cs cm'+          | otherwise                            = f (csAcc `CS.union` cs) cm'++    logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a+    logBackjump cs !cm = failWith (Failure cs Backjump) (cs, updateCM initial cm)+                                   -- 'intial' instead of 'cs' here ---^+                                   -- since we do not want to double-count the+                                   -- additionally accumulated conflicts.++type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap)++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.alter inc k cmc) cm (CS.toList cs)+  where+    inc Nothing  = Just 1+    inc (Just n) = Just $! n + 1++-- | 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 :: EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason+           -> ConflictSetLog (Assignment, RevDepMap)+exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty+  where+    getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)+    getBestGoal'+      | countConflicts = \ ts cm -> getBestGoal cm ts+      | otherwise      = \ ts _  -> getFirstGoal ts++    go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))+                                    -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))+    go (FailF c fr)                            = \ !cm -> failWith (Failure c fr)+                                                                 (c, updateCM c cm)+    go (DoneF rdm a)                           = \ _   -> succeedWith Success (a, rdm)+    go (PChoiceF qpn _ gr       ts)            =+      backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryP qpn k) (r cm))+          ts+    go (FChoiceF qfn _ gr _ _ _ ts)            =+      backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryF qfn k) (r cm))+          ts+    go (SChoiceF qsn _ gr _     ts)            =+      backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,+        W.mapWithKey                                -- when descending ...+          (\ k r cm -> tryWith (TryS qsn k) (r cm))+          ts+    go (GoalChoiceF _           ts)            = \ cm ->+      let (k, v) = getBestGoal' ts cm+      in continueWith (Next k) (v cm)++-- | 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 actual 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 initial 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 initial 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 gr =+  CS.fromList (var : goalReasonToVars gr)++-- | Interface.+backjumpAndExplore :: EnableBackjumping+                   -> CountConflicts+                   -> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)+backjumpAndExplore enableBj countConflicts =+    toProgress . exploreLog enableBj countConflicts . assign
+ Distribution/Solver/Modular/Flag.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Flag+    ( FInfo(..)+    , Flag+    , FlagInfo+    , FN(..)+    , QFN+    , QSN+    , SN(..)+    , WeakOrTrivial(..)+    , mkFlag+    , showFBool+    , showQFN+    , showQFNBool+    , showQSN+    , showQSNBool+    ) where++import Data.Map as M+import Prelude hiding (pi)++import Distribution.PackageDescription hiding (Flag) -- from Cabal++import Distribution.Solver.Modular.Package+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 (PI qpn) Flag+  deriving (Eq, Ord, Show, Functor)++-- | Flag identifier. Just a string.+type Flag = FlagName++unFlag :: Flag -> String+unFlag = unFlagName++mkFlag :: String -> Flag+mkFlag = 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 (PI qpn) OptionalStanza+  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)++showQFNBool :: QFN -> Bool -> String+showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b++showQSNBool :: QSN -> Bool -> String+showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b++showFBool :: FN qpn -> Bool -> String+showFBool (FN _ f) v = showFlagValue (f, v)++showSBool :: SN qpn -> Bool -> String+showSBool (SN _ s) True  = "*" ++ showStanza s+showSBool (SN _ s) False = "!" ++ showStanza s++showQFN :: QFN -> String+showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f++showQSN :: QSN -> String+showQSN (SN pi s) = showPI pi ++ ":" ++ showStanza s
+ Distribution/Solver/Modular/Index.hs view
@@ -0,0 +1,52 @@+module Distribution.Solver.Modular.Index+    ( Index+    , PInfo(..)+    , defaultQualifyOptions+    , mkIndex+    ) where++import Data.List as L+import Data.Map as M+import Prelude hiding (pi)++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree++import Distribution.Solver.Types.ComponentDeps (Component)++-- | 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, flags and failure reasons.+-- 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 Component PN) FlagInfo (Maybe FailReason)+  deriving (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 _flagNfo _fr) <- M.toList is+                                -- .. and flatten all their dependencies ..+                              , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps+                              ]+    , qoSetupIndependent = True+    }+  where+    base = mkPackageName "base"
+ Distribution/Solver/Modular/IndexConversion.hs view
@@ -0,0 +1,350 @@+module Distribution.Solver.Modular.IndexConversion+    ( convPIs+    ) where++import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Monoid as Mon+import Data.Set as S+import Prelude hiding (pi)++import Distribution.Compiler+import Distribution.InstalledPackageInfo as IPI+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.UnqualComponentName        -- from Cabal+import Distribution.Types.CondTree                   -- from Cabal+import Distribution.Types.MungedPackageId            -- from Cabal+import Distribution.Types.MungedPackageName          -- from Cabal+import Distribution.PackageDescription as PD         -- from Cabal+import Distribution.PackageDescription.Configuration as PDC+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.System+import Distribution.Types.ForeignLib++import           Distribution.Solver.Types.ComponentDeps+                   ( Component(..), componentNameToComponent )+import           Distribution.Solver.Types.Flag+import           Distribution.Solver.Types.OptionalStanza+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 -> ShadowPkgs -> StrongFlags -> SolveExecutables ->+           SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index+convPIs os arch comp sip strfl sexes iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes 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 fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))+    shadow x                                = x++-- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I.+convId :: 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 = mkPackageName (unMungedPackageName mpn)++-- | Convert a single installed package into the solver-specific format.+convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP idx ipi =+  case mapM (convIPId pn idx) (IPI.depends ipi) of+        Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))+        Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)+ where+  (pn, i) = convId ipi+  -- 'sourceLibName' is unreliable, but for now we only really use this for+  -- primary libs anyways+  setComp = setCompFlaggedDeps $ componentNameToComponent+    $ libraryComponentName $ 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 :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN)+convIPId pn' idx ipid =+  case SI.lookupUnitId idx ipid of+    Nothing  -> Nothing+    Just ipi -> let (pn, i) = convId ipi+                in  Just (D.Simple (Dep False pn (Fixed i (P pn'))) ())+                -- 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 -> StrongFlags -> SolveExecutables ->+            CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]+convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages++-- | Convert a single source package into the solver-specific format.+convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)+convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =+  let i = I pv InRepo+  in  (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) 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 -> StrongFlags -> SolveExecutables ->+           PI PN -> GenericPackageDescription -> PInfo+convGPD os arch cinfo strfl sexes pi+        (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) =+  let+    fds  = flagInfo strfl flags++    -- | We have to be careful to filter out dependencies on+    -- internal libraries, since they don't refer to real packages+    -- and thus cannot actually be solved over.  We'll do this+    -- by creating a set of package names which are "internal"+    -- and dropping them as we convert.++    ipns = S.fromList $ [ unqualComponentNameToPackageName nm+                        | (nm, _) <- sub_libs ]++    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->+            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+    conv comp getInfo = convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes .+                        PDC.addBuildableCondition getInfo++    flagged_deps+        = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib)+       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm)   libBuildInfo       ds) sub_libs+       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)  foreignLibBuildInfo ds) flibs+       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes+       ++ prefix (Stanza (SN pi TestStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)+       ++ prefix (Stanza (SN pi BenchStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)+       ++ maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)++  in+    PInfo flagged_deps fds Nothing++-- | 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 comp qpn -> FlaggedDep comp' qpn)+       -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' 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 -> [PD.Flag] -> FlagInfo+flagInfo (StrongFlags strfl) =+    M.fromList . L.map (\ (MkFlag 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++-- | Internal package names, which should not be interpreted as true+-- dependencies.+type IPNs = Set PN++-- | Convenience function to delete a 'FlaggedDep' if it's+-- for a 'PN' that isn't actually real.+filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN+filterIPNs ipns (Dependency pn _) fd+    | S.notMember pn ipns = [fd]+    | otherwise           = []++-- | Convert condition trees to flagged dependencies.  Mutually+-- recursive with 'convBranch'.  See 'convBranch' for an explanation+-- of all arguments preceeding the input 'CondTree'.+convCondTree :: PackageDescription -> OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->+                Component ->+                (a -> BuildInfo) ->+                IPNs ->+                SolveExecutables ->+                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+convCondTree pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) =+                 concatMap+                    (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp))+                    ds  -- unconditional package dependencies+              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch pkg os arch cinfo pi fds comp getInfo ipns sexes) 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 pn exeDep) comp+                 | sexes'+                 , exeDep <- getAllToolDependencies pkg bi+                 , not $ isInternal pkg exeDep+                 ]+  where+    bi = getInfo info++-- | 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. Some pre dependency-solving known information ('OS', 'Arch',+--         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,+--+--      2. The package instance @'PI' 'PN'@ which this condition tree+--         came from, so that we can correctly associate @flag()@+--         variables with the correct package name qualifier,+--+--      3. The flag defaults 'FlagInfo' so that we can populate+--         'Flagged' dependencies with 'FInfo',+--+--      4. The name of the component 'Component' so we can record where+--         the fine-grained information about where the component came+--         from (see 'convCondTree'), and+--+--      5. A selector to extract the 'BuildInfo' from the leaves of+--         the 'CondTree' (which actually contains the needed+--         dependency information.)+--+--      6. The set of package names which should be considered internal+--         dependencies, and thus not handled as dependencies.+convBranch :: PackageDescription -> OS -> Arch -> CompilerInfo ->+              PI PN -> FlagInfo ->+              Component ->+              (a -> BuildInfo) ->+              IPNs ->+              SolveExecutables ->+              CondBranch ConfVar [Dependency] a ->+              FlaggedDeps Component PN+convBranch pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (CondBranch c' t' mf') =+  go c' (          convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes  t')+        (maybe [] (convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes) mf')+  where+    go :: Condition ConfVar ->+          FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component 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 (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]+    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++    -- If both branches contain the same package as a simple dep, we lift it to+    -- the next higher-level, but without constraints. This heuristic together+    -- with deferring flag choices will then usually first resolve this package,+    -- and try an already installed version before imposing a default flag choice+    -- that might not be what we want.+    --+    -- Note that we make assumptions here on the form of the dependencies that+    -- can occur at this point. In particular, no occurrences of Fixed, and no+    -- occurrences of multiple version ranges, as all dependencies below this+    -- point have been generated using 'convLibDep'.+    --+    -- WARNING: This is quadratic!+    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN+    extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp+                           | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps+                           , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps'+                           , pn1 == pn2+                           , is_exe1 == is_exe2+                           ]++-- | Convert a Cabal dependency on a library to a solver-specific dependency.+convLibDep :: PN -> Dependency -> Dep PN+convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')])++-- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency.+-- TODO do something about the name of the exe component itself+convExeDep :: PN -> ExeDependency -> Dep PN+convExeDep pn' (ExeDependency pn _ vr) = Dep True pn (Constrained [(vr, P pn')])++-- | Convert setup dependencies+convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN+convSetupBuildInfo (PI pn _i) nfo =+    L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo)
+ Distribution/Solver/Modular/LabeledGraph.hs view
@@ -0,0 +1,116 @@+-- | 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 Data.Array+import Data.Graph (Vertex, Bounds)+import Data.List (sortBy)+import Data.Maybe (mapMaybe)+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       = zipWith (,) [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 view
@@ -0,0 +1,517 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Distribution.Solver.Modular.Linking (+    validateLinking+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get,put)++import Control.Exception (assert)+import Control.Monad.Reader+import Control.Monad.State+import Data.Map ((!))+import Data.Set (Set)+import qualified Data.Map         as M+import qualified Data.Set         as S+import qualified Data.Traversable as T++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.Solver.Types.ComponentDeps (Component)+import Distribution.Types.GenericPackageDescription (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+    }+    deriving Show++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+      case execUpdateState (pickPOption qpn opt qdeps) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') 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+      }++{-------------------------------------------------------------------------------+  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 Component 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 Component 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 [] lgSource lgTarget+    updateLinkGroup lgTarget'++    -- Make sure all dependencies are linked as well+    linkDeps target [P qpn] 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 -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()+linkDeps target = \blame 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 blame deps rdeps+  where+    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()+    go = zipWithM_ . go1++    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()+    go1 blame dep rdep = case (dep, rdep) of+      (Simple (Dep _ qpn _) _, ~(Simple (Dep _ 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 blame 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 (F fn:blame) t t'+          Just False -> go (F fn:blame) 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 (S sn:blame) 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 for pkg-config constraints.+      (Simple (Ext  _)   _, _) -> return ()+      (Simple (Lang _)   _, _) -> return ()+      (Simple (Pkg  _ _) _, _) -> return ()++    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component 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 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), Just i) = varPI var+        PInfo deps _ _          = vsIndex vs ! pn ! i+        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps+        lg                      = vsLinks vs ! qpn+        (parents, newDeps)      = findNewDeps vs qdeps+        linkedTo                = S.delete pp (lgMembers lg)+    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps+  where+    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)+    findNewDeps vs = concatMapUnzip (findNewDeps' vs)++    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)+    findNewDeps' _  (Simple _ _)        = ([], [])+    findNewDeps' vs (Flagged qfn _ t f) =+      case (F qfn == var, M.lookup qfn (vsFlags vs)) of+        (True, _)    -> ([F qfn], if b then t else f)+        (_, Nothing) -> ([], []) -- not yet known+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)+                        in (F qfn:parents, deps)+    findNewDeps' vs (Stanza qsn t) =+      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of+        (True, _)    -> ([S qsn], if b then t else [])+        (_, Nothing) -> ([], []) -- not yet known+        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])+                        in (S qsn:parents, deps)++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 finfo _ = vsIndex vs ! lgPackage lg ! i+            flags   = M.keys finfo+            stanzas = [TestStanzas, BenchStanzas]+        forM_ flags $ \fn -> do+          let flag = FN (PI (lgPackage lg) i) fn+          verifyFlag' flag lg+        forM_ stanzas $ \sn -> do+          let stanza = SN (PI (lgPackage lg) i) sn+          verifyStanza' stanza lg++verifyFlag :: QFN -> UpdateState ()+verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do+    vs <- get+    -- We can only pick a flag after picking an instance; link group must exist+    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)++verifyStanza :: QSN -> UpdateState ()+verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do+    vs <- get+    -- We can only pick a stanza after picking an instance; link group must exist+    verifyStanza' (SN (PI pn i) 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 (PI pn i) fn) lg = do+    vs <- get+    let flags = map (\pp' -> FN (PI (Q pp' pn) i) 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 (PI pn i) sn) lg = do+    vs <- get+    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) 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 :: [Var QPN] -> 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 [CS.fromList 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 [+                               CS.fromList 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)++concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])+concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f
+ Distribution/Solver/Modular/Log.hs view
@@ -0,0 +1,92 @@+module Distribution.Solver.Modular.Log+    ( Log+    , logToProgress+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Data.List as L++import Distribution.Solver.Types.Progress++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Tree (FailReason(..))+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Verbosity++-- | The 'Log' datatype.+--+-- Represents the progress of a computation lazily.+--+-- Parameterized over the type of actual messages and the final result.+type Log m a = Progress m (ConflictSet, ConflictMap) a++messages :: Progress step fail done -> [step]+messages = foldProgress (:) (const []) (const [])++data Exhaustiveness = Exhaustive | BackjumpLimitReached++-- | Postprocesses a log file. 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.+logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a+logToProgress verbosity mbj l =+    let es = proc (Just 0) l -- catch first error (always)+        ms = proc mbj l+    in go es es -- trace for first error+          (showMessages (const True) True ms) -- run with backjump limit applied+  where+    -- Proc takes the allowed number of backjumps and a 'Progress' and explores the+    -- messages until the maximum number of backjumps has been reached. It filters out+    -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates+    -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the+    -- original result.+    proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b+    proc _        (Done x)                          = Done x+    proc _        (Fail (cs, cm))                   = Fail (Exhaustive, cs, cm)+    proc mbj'     (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))+      | cs == cs'                                   = Step x (proc mbj'           xs) -- repeated backjumps count as one+    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available+    proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)+    proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs)++    -- The first two arguments are both supposed to be the log up to the first error.+    -- That's the error that will always be printed in case we do not find a solution.+    -- We pass this log twice, because we evaluate it in parallel with the full log,+    -- but we also want to retain the reference to its beginning for when we print it.+    -- This trick prevents a space leak!+    --+    -- The third argument is the full log, ending with either the solution or the+    -- exhaustiveness and final conflict set.+    go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b+       -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b+       -> Progress String  (Exhaustiveness, ConflictSet, ConflictMap) b+       -> Progress String String b+    go ms (Step _ ns)        (Step x xs)           = Step x (go ms ns xs)+    go ms r                  (Step x xs)           = Step x (go ms r  xs)+    go ms (Step _ ns)        r                     = go ms ns r+    go ms (Fail (_, cs', _)) (Fail (exh, cs, cm))  = Fail $+        "Could not resolve dependencies:\n" +++        unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) +++        case exh of+            Exhaustive ->+                "After searching the rest of the dependency tree exhaustively, "+                ++ "these were the goals I've had most trouble fulfilling: "+                ++ showCS cm cs+              where+                showCS = if verbosity > normal+                         then CS.showCSWithFrequency+                         else CS.showCSSortedByFrequency+            BackjumpLimitReached ->+                "Backjump limit reached (" ++ currlimit mbj +++                "change with --max-backjumps or try to run with --reorder-goals).\n"+              where currlimit (Just n) = "currently " ++ show n ++ ", "+                    currlimit Nothing  = ""+    go _  _                  (Done s)              = Done s+    go _  (Done _)           (Fail _)              = Fail $+        -- Should not happen: Second argument is the log up to first error,+        -- third one is the entire log. Therefore it should never happen that+        -- the second log finishes with 'Done' and the third log with 'Fail'.+        "Could not resolve dependencies; something strange happened."
+ Distribution/Solver/Modular/Message.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}++module Distribution.Solver.Modular.Message (+    Message(..),+    showMessages+  ) where++import qualified Data.List as L+import Prelude hiding (pi)++import Distribution.Text -- from Cabal++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+         ( FailReason(..), POption(..) )+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Progress++data Message =+    Enter           -- ^ increase indentation level+  | Leave           -- ^ decrease indentation level+  | TryP QPN POption+  | TryF QFN Bool+  | TryS QSN Bool+  | Next (Goal QPN)+  | Success+  | Failure ConflictSet FailReason++-- | Transforms the structured message type to actual messages (strings).+--+-- Takes an additional relevance predicate. The predicate gets a stack of goal+-- variables and can decide whether messages regarding these goals are relevant.+-- You can plug in 'const True' if you're interested in a full trace. If you+-- want a slice of the trace concerning a particular conflict set, then plug in+-- a predicate returning 'True' on the empty stack and if the head is in the+-- conflict set.+--+-- The second argument indicates if the level numbers should be shown. This is+-- recommended for any trace that involves backtracking, because only the level+-- numbers will allow to keep track of backjumps.+showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b+showMessages p sl = go [] 0+  where+    -- The stack 'v' represents variables that are currently assigned by the+    -- solver.  'go' pushes a variable for a recursive call when it encounters+    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.+    -- When 'go' processes a package goal, or a package goal followed by a+    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the+    -- stack so that the predicate can also select messages relating to package+    -- goal choices.+    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b+    go !_ !_ (Done x)                           = Done x+    go !_ !_ (Fail x)                           = Fail x+    -- complex patterns+    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        goPReject v l qpn [i] c fr ms+    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =+        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) =+        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms+        -- the previous case potentially arises in the error output, because we remove the backjump itself+        -- if we cut the log after the first error+    go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) =+        (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =+        let v' = add (P qpn) v+        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)+    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))+        | c == c' = go v l ms+    -- standard display+    go !v !l (Step Enter                    ms) = go v          (l+1) ms+    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms+    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)+    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)+    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)+    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log+    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)+    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v 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++    add :: Var QPN -> [Var QPN] -> [Var QPN]+    add v vs = simplifyVar v : vs++    -- special handler for many subsequent package rejections+    goPReject :: [Var QPN]+              -> Int+              -> QPN+              -> [POption]+              -> ConflictSet+              -> FailReason+              -> Progress Message a b+              -> Progress String a b+    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))+      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms+    goPReject v l qpn is c fr ms =+        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)++    -- write a message, but only if it's relevant; we can also enable or disable the display of the current level+    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b+    atLevel v l x xs+      | sl && p v = let s = show l+                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs+      | p v       = Step x xs+      | otherwise = xs++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 (PDependency pi)    = " (dependency of " ++ showPI pi            ++ ")"+showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b    ++ ")"+showGR (SDependency qsn)   = " (dependency of " ++ showQSNBool qsn True ++ ")"++showFR :: ConflictSet -> FailReason -> String+showFR _ InconsistentInitialConstraints   = " (inconsistent initial constraints)"+showFR _ (Conflicting ds)                 = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"+showFR _ CannotInstall                    = " (only already installed instances can be used)"+showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"+showFR _ Shadowed                         = " (shadowed by another installed package with same version)"+showFR _ Broken                           = " (package is broken)"+showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display 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 ++ ")"+-- 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)"++constraintSource :: ConstraintSource -> String+constraintSource src = "constraint from " ++ showConstraintSource src
+ Distribution/Solver/Modular/PSQ.hs view
@@ -0,0 +1,157 @@+{-# 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+    , splits+    , 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)++splits :: PSQ k a -> PSQ k (a, PSQ k a)+splits = go id+  where+    go f xs = casePSQ xs+        (PSQ [])+        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) 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 view
@@ -0,0 +1,109 @@+{-# 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 Data.List as L++import Distribution.Package -- from Cabal+import Distribution.Text (display)++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" ++ shortId uid+  where+    -- A hack to extract the beginning of the package ABI hash+    shortId = snip (splitAt 4) (++ "...")+            . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+            . display+    snip p f xs = case p xs of+                    (ys, zs) -> (if L.null zs then id else f) ys++-- | 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++-- | Create artificial parents for each of the package names, making+-- them all independent.+makeIndependent :: [PN] -> [QPN]+makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]+                               , let pp = PackagePath (Independent i) QualToplevel+                     ]
+ Distribution/Solver/Modular/Preference.hs view
@@ -0,0 +1,455 @@+{-# 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+    , sortGoals+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Data.Function (on)+import qualified Data.List as L+import qualified Data.Map as M+import Control.Monad.Reader hiding (sequence)+import Data.Traversable (sequence)++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 (PI (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 L.lookup 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 (PI 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 (PI 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.+--+-- 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 (PI (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',+              -- regardless of scope.+              flagConstraintValues :: [Bool]+              flagConstraintValues =+                  [ flagVal+                  | let lpcs = M.findWithDefault [] pn pcs+                  , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs+                  , (fn', flagVal) <- 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++-- | 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 (PI qpn _) fn))     = FlagVar qpn fn+    varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza++-- | 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 <$> sequence (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 view
@@ -0,0 +1,69 @@+{-# LANGUAGE Rank2Types #-}+module Distribution.Solver.Modular.RetryLog+    ( RetryLog+    , toProgress+    , fromProgress+    , mapFailure+    , retry+    , failWith+    , succeedWith+    , continueWith+    , tryWith+    ) where++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 view
@@ -0,0 +1,237 @@+{-# LANGUAGE CPP #-}+#ifdef DEBUG_TRACETREE+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif+module Distribution.Solver.Modular.Solver+    ( SolverConfig(..)+    , solve+    ) where++import Data.Map as M+import Data.List as L+import Data.Set as S+import Distribution.Verbosity+import Distribution.Version++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.Tree+import qualified Distribution.Solver.Modular.PSQ as PSQ++import Distribution.Simple.Setup (BooleanFlag(..))++#ifdef DEBUG_TRACETREE+import Distribution.Solver.Modular.Flag+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import qualified Distribution.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,+  independentGoals      :: IndependentGoals,+  avoidReinstalls       :: AvoidReinstalls,+  shadowPkgs            :: ShadowPkgs,+  strongFlags           :: StrongFlags,+  allowBootLibInstalls  :: AllowBootLibInstalls,+  maxBackjumps          :: Maybe Int,+  enableBackjumping     :: EnableBackjumping,+  solveExecutables      :: SolveExecutables,+  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering),+  solverVerbosity       :: Verbosity+}++-- | 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+      -> Map PN [LabeledPackageConstraint]    -- ^ global constraints+      -> Set PN                               -- ^ global goals+      -> Log Message (Assignment, RevDepMap)+solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =+  explorePhase     $+  detectCycles     $+  heuristicsPhase  $+  preferencesPhase $+  validationPhase  $+  prunePhase       $+  buildPhase+  where+    explorePhase     = backjumpAndExplore (enableBackjumping sc) (countConflicts sc)+    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase+    heuristicsPhase  =+      let heuristicsTree = traceTree "heuristics.json" id+      in case goalOrder sc of+           Nothing -> goalChoiceHeuristics .+                      heuristicsTree .+                      P.deferSetupChoices .+                      P.deferWeakFlagChoices .+                      P.preferBaseGoalChoice+           Just order -> P.firstGoal .+                         heuristicsTree .+                         P.sortGoals order+    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))+    buildPhase       = traceTree "build.json" id+                     $ buildTree idx (independentGoals sc) (S.toList userGoals)++    -- 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 (PDependency (PI nm _)) = showQPN nm+      shortGR (FDependency nm _)      = showQFN nm+      shortGR (SDependency nm)        = showQSN nm++      -- 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 = PDependency+         $ PI (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))+              (I (mkVersion [1]) InRepo)
+ Distribution/Solver/Modular/Tree.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.Tree+    ( FailReason(..)+    , POption(..)+    , Tree(..)+    , TreeF(..)+    , Weight+    , ana+    , cata+    , inn+    , innM+    , para+    , trav+    , zeroOrOneChoices+    ) 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++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+  deriving (Eq, Show)++-- | 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 = InconsistentInitialConstraints+                | Conflicting [Dep QPN]+                | CannotInstall+                | CannotReinstall+                | Shadowed+                | Broken+                | GlobalConstraintVersion VR ConstraintSource+                | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintSource ConstraintSource+                | GlobalConstraintFlag ConstraintSource+                | ManualFlag+                | MalformedFlagChoice QFN+                | MalformedStanzaChoice QSN+                | EmptyGoalChoice+                | Backjump+                | MultipleInstances+                | DependenciesNotLinked String+                | CyclicDependencies+  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 view
@@ -0,0 +1,278 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+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.List as L+import Data.Map as M+import Data.Set as S+import Data.Traversable+import Prelude hiding (sequence)++import Language.Haskell.Extension (Extension, Language)++import Distribution.Compiler (CompilerInfo(..))++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 Distribution.Solver.Modular.Version (VR)+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.ComponentDeps (Component)++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)++-- 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 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 -> VR  -> Bool,+  index :: Index,+  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment,+  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++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+      qo             <- asks qualifyOptions+      -- obtain dependencies and index-dictated exclusions introduced by the choice+      let (PInfo deps _ 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+      -- TODO: is the False here right?+      let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps)+      -- We now try to extend the partial assignment with the new active constraints.+      let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives+      -- 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)+        _       -> case mnppa of+                     Left (c, d) -> -- We have an inconsistency. We can stop.+                                    return (Fail c (Conflicting d))+                     Right nppa  -> -- We have an updated partial assignment for the recursive validation.+                                    local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r++    -- What to do for flag nodes ...+    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goF qfn@(FN (PI qpn _i) _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+      -- 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+      -- As in the package case, we try to extend the partial assignment.+      case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) 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 (PI qpn _i) _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+      -- 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+      -- As in the package case, we try to extend the partial assignment.+      case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of+        Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found+        Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r++-- | 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.+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]+extractDeps 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  -> extractDeps fa sa td+                             Just False -> extractDeps fa sa fd+    Stanza qsn td       -> case M.lookup qsn sa of+                             Nothing    -> mzero+                             Just True  -> extractDeps 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+-- 'extractDeps' for everything underneath.+extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]+extractNewDeps v b fa sa = go+  where+    go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)+    go deps = do+      d <- deps+      case d of+        Simple _ _           -> mzero+        Flagged qfn' _ td fd+          | v == F qfn'      -> L.map (resetVar v) $+                                if b then extractDeps fa sa td else extractDeps 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'      -> L.map (resetVar v) $+                                if b then extractDeps fa sa td else []+          | otherwise        -> case M.lookup qsn' sa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> []++-- | 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+  , qualifyOptions = defaultQualifyOptions idx+  }
+ Distribution/Solver/Modular/Var.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Var (+    Var(..)+  , simplifyVar+  , showVar+  , varPI+  ) where++import Prelude hiding (pi)++import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+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)++-- | For computing conflict sets, we map flag choice vars to a+-- single flag choice. This means that all flag choices are treated+-- as interdependent. So if one flag of a package ends up in a+-- conflict set, then all flags are being treated as being part of+-- the conflict set.+simplifyVar :: Var qpn -> Var qpn+simplifyVar (P qpn)       = P qpn+simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))+simplifyVar (S qsn)       = S qsn++showVar :: Var QPN -> String+showVar (P qpn) = showQPN qpn+showVar (F qfn) = showQFN qfn+showVar (S qsn) = showQSN qsn++-- | Extract the package instance from a Var+varPI :: Var QPN -> (QPN, Maybe I)+varPI (P qpn)               = (qpn, Nothing)+varPI (F (FN (PI qpn i) _)) = (qpn, Just i)+varPI (S (SN (PI qpn i) _)) = (qpn, Just i)
+ Distribution/Solver/Modular/Version.hs view
@@ -0,0 +1,53 @@+module Distribution.Solver.Modular.Version+    ( Ver+    , VR+    , anyVR+    , checkVR+    , eqVR+    , showVer+    , showVR+    , simplifyVR+    , (.&&.)+    , (.||.)+    ) where++import qualified Distribution.Version as CV -- from Cabal+import Distribution.Text -- from Cabal++-- | Preliminary type for versions.+type Ver = CV.Version++-- | String representation of a version.+showVer :: Ver -> String+showVer = display++-- | Version range. Consists of a lower and upper bound.+type VR = CV.VersionRange++-- | String representation of a version range.+showVR :: VR -> String+showVR = display++-- | 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+(.&&.) = CV.intersectVersionRanges++-- | Union of two version ranges.+(.||.) :: VR -> VR -> VR+(.||.) = CV.unionVersionRanges++-- | 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 view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.WeightedPSQ (+    WeightedPSQ+  , fromList+  , toList+  , keys+  , weights+  , isZeroOrOne+  , filter+  , lookup+  , mapWithKey+  , mapWeightsWithKey+  , union+  ) 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)++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 view
@@ -0,0 +1,194 @@+{-# 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+  ) where++import Prelude ()+import Distribution.Types.UnqualComponentName+import Distribution.Client.Compat.Prelude hiding (empty,zip)++import qualified Data.Map as Map+import Data.Foldable (fold)++import qualified Distribution.Types.ComponentName as CN++{-------------------------------------------------------------------------------+  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++-- | 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)++componentNameToComponent :: CN.ComponentName -> Component+componentNameToComponent (CN.CLibName)      = ComponentLib+componentNameToComponent (CN.CSubLibName 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)+{- TODO/FIXME: Once we can expect containers>=0.5, switch to the more efficient version below:++zip (ComponentDeps d1) (ComponentDeps d2) =+    ComponentDeps $+      Map.mergeWithKey+        (\_ a b -> Just (a,b))+        (fmap (\a -> (a, mempty)))+        (fmap (\b -> (mempty, b)))+        d1 d2++-}+zip (ComponentDeps d1) (ComponentDeps d2) =+    ComponentDeps $+      Map.unionWith+        mappend+        (Map.map (\a -> (a, mempty)) d1)+        (Map.map (\b -> (mempty, b)) 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)++-- | 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 view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ConstraintSource+    ( ConstraintSource(..)+    , showConstraintSource+    ) where++import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))++-- | 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+  deriving (Eq, Show, Generic)++instance Binary 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"
+ Distribution/Solver/Types/DependencyResolver.hs view
@@ -0,0 +1,36 @@+module Distribution.Solver.Types.DependencyResolver+    ( DependencyResolver+    ) where++import Data.Set (Set)++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 view
@@ -0,0 +1,6 @@+module Distribution.Solver.Types.Flag+    ( FlagType(..)+    ) where++data FlagType = Manual | Automatic+  deriving (Eq, Show)
+ Distribution/Solver/Types/InstSolverPackage.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.InstSolverPackage +    ( InstSolverPackage(..)+    ) where++import Distribution.Compat.Binary (Binary(..))+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.PackageName+import Distribution.Types.MungedPackageName+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import GHC.Generics (Generic)++-- | An 'InstSolverPackage' is a pre-existing installed pacakge+-- specified by the dependency solver.+data InstSolverPackage = InstSolverPackage {+      instSolverPkgIPI :: InstalledPackageInfo,+      instSolverPkgLibDeps :: ComponentDeps [SolverId],+      instSolverPkgExeDeps :: ComponentDeps [SolverId]+    }+  deriving (Eq, Show, Generic)++instance Binary InstSolverPackage++instance Package InstSolverPackage where+    packageId i =+        -- HACK! See Note [Index conversion with internal libraries]+        let MungedPackageId mpn v = mungedId i+        in PackageIdentifier (mkPackageName (unMungedPackageName mpn)) v++instance HasMungedPackageId InstSolverPackage where+    mungedId = mungedId . instSolverPkgIPI++instance HasUnitId InstSolverPackage where+    installedUnitId = installedUnitId . instSolverPkgIPI
+ Distribution/Solver/Types/InstalledPreference.hs view
@@ -0,0 +1,9 @@+module Distribution.Solver.Types.InstalledPreference+    ( InstalledPreference(..),+    ) where++-- | 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 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
+ Distribution/Solver/Types/OptionalStanza.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Distribution.Solver.Types.OptionalStanza+    ( OptionalStanza(..)+    , showStanza+    , enableStanzas+    ) where++import GHC.Generics (Generic)+import Data.Typeable+import Distribution.Compat.Binary (Binary(..))+import Distribution.Types.ComponentRequestedSpec+            (ComponentRequestedSpec(..), defaultComponentRequestedSpec)+import Data.List (foldl')++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
+ Distribution/Solver/Types/PackageConstraint.hs view
@@ -0,0 +1,133 @@+{-# 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.Compat.Binary      (Binary(..))+import Distribution.Package            (PackageName)+import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)+import Distribution.Types.Dependency   (Dependency(..))+import Distribution.Version            (VersionRange, simplifyVersionRange)++import Distribution.Client.Compat.Prelude ((<<>>))+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++import Distribution.Text                  (disp, flatStyle)+import GHC.Generics                       (Generic)+import Text.PrettyPrint                   ((<+>))+import qualified Text.PrettyPrint as Disp+++-- | Determines to what packages and in what contexts a+-- constraint applies.+data ConstraintScope+     -- | 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 (ScopeQualified _ pn) = pn+scopeToPackageName (ScopeAnySetupQualifier pn) = pn+scopeToPackageName (ScopeAnyQualifier pn) = pn++constraintScopeMatches :: ConstraintScope -> QPN -> Bool+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 (ScopeQualified q pn) = dispQualifier q <<>> disp pn+dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn+dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp 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++-- | Pretty-prints a package property.+dispPackageProperty :: PackageProperty -> Disp.Doc+dispPackageProperty (PackagePropertyVersion verrange) = disp 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 Dependency+packageConstraintToDependency (PackageConstraint scope prop) = toDep prop+  where+    toDep (PackagePropertyVersion vr) = +        Just $ Dependency (scopeToPackageName scope) vr+    toDep (PackagePropertyInstalled)  = Nothing+    toDep (PackagePropertySource)     = Nothing+    toDep (PackagePropertyFlags _)    = Nothing+    toDep (PackagePropertyStanzas _)  = Nothing
+ 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)+
+ Distribution/Solver/Types/PackageIndex.hs view
@@ -0,0 +1,316 @@+{-# 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,+  insert,+  deletePackageName,+  deletePackageId,+  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  elemByPackageId,+  elemByPackageName,+  lookupPackageName,+  lookupPackageId,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (lookup)++import Control.Exception (assert)+import qualified Data.Map as Map+import Data.List (groupBy, isInfixOf)++import Distribution.Package+         ( PackageName, unPackageName, PackageIdentifier(..)+         , Package(..), packageName, packageVersion )+import Distribution.Types.Dependency+import Distribution.Version+         ( withinRange )+import Distribution.Simple.Utils+         ( lowercase, comparing )+++-- | 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 = 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 head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . 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++-- | 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 => Dependency -> PackageIndex pkg+                 -> PackageIndex pkg+deleteDependency (Dependency 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 -> Dependency -> [pkg]+lookupDependency index (Dependency 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 (PackageIndex m) searchterm =+    [ pkgs+    | pkgs@(pname, _) <- Map.toList m+    , lsearchterm `isInfixOf` lowercase (unPackageName pname) ]+  where+    lsearchterm = lowercase searchterm
+ Distribution/Solver/Types/PackagePath.hs view
@@ -0,0 +1,103 @@+module Distribution.Solver.Types.PackagePath+    ( PackagePath(..)+    , Namespace(..)+    , Qualifier(..)+    , dispQualifier+    , Qualified(..)+    , QPN+    , dispQPN+    , showQPN+    ) where++import Distribution.Package+import Distribution.Text+import qualified Text.PrettyPrint as Disp+import Distribution.Client.Compat.Prelude ((<<>>))++-- | 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++    -- | Independent namespace+    --+    -- For now we just number these (rather than giving them more structure).+  | Independent Int+  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) = Disp.int 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)  = disp pn <<>> Disp.text ":setup."+dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>>+                                 disp pn2 <<>> Disp.text ":exe."+dispQualifier (QualBase pn)  = disp 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 <<>> disp pn++-- | String representation of a qualified package name.+showQPN :: QPN -> String+showQPN = Disp.renderStyle flatStyle . dispQPN
+ 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]
+ Distribution/Solver/Types/PkgConfigDb.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- 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 Prelude ()+import Distribution.Client.Compat.Prelude++import Control.Exception (IOException, handle)+import qualified Data.Map as M+import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)+import System.FilePath (splitSearchPath)++import Distribution.Package+    ( PkgconfigName, mkPkgconfigName )+import Distribution.Verbosity+    ( Verbosity )+import Distribution.Version+    ( Version, mkVersion', VersionRange, withinRange )++import Distribution.Compat.Environment+    ( lookupEnv )+import Distribution.Simple.Program+    ( ProgramDb, pkgConfigProgram, getProgramOutput, requireProgram )+import Distribution.Simple.Utils+    ( info )++-- | 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 Version))+                 -- ^ 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++-- | Query pkg-config for the list of installed packages, together+-- with their versions. Return a `PkgConfigDb` encapsulating this+-- information.+readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb+readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do+  (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb+  pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]+  -- The output of @pkg-config --list-all@ also includes a description+  -- for each package, which we do not need.+  let pkgNames = map (takeWhile (not . isSpace)) pkgList+  pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig+                             ("--modversion" : pkgNames)+  (return . pkgConfigDbFromList . zip pkgNames) pkgVersions+      where+        -- For when pkg-config invocation fails (possibly because of a+        -- too long command line).+        ioErrorHandler :: IOException -> IO PkgConfigDb+        ioErrorHandler e = do+          info verbosity ("Failed to query pkg-config, Cabal will continue"+                          ++ " without solving for pkg-config constraints: "+                          ++ show e)+          return NoPkgConfigDb++-- | 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 Version)+      convert (n,vs) = (mkPkgconfigName n,+                        case (reverse . readP_to_S parseVersion) vs of+                          (v, "") : _ -> Just (mkVersion' v)+                          _           -> Nothing -- Version not (fully)+                                                 -- understood.+                       )++-- | Check whether a given package range is satisfiable in the given+-- @pkg-config@ database.+pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> VersionRange -> 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) -> withinRange 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 Version)+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+      (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb+      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 view
@@ -0,0 +1,49 @@+module Distribution.Solver.Types.Progress+    ( Progress(..)+    , foldProgress+    ) where++import Prelude ()+import Distribution.Client.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://ghc.haskell.org/trac/ghc/ticket/7436#comment:6.+-- 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 view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ResolverPackage+    ( ResolverPackage(..)+    , resolverPackageLibDeps+    , resolverPackageExeDeps+    ) where++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.Binary (Binary(..))+import Distribution.Compat.Graph (IsNode(..))+import Distribution.Package (Package(..), HasUnitId(..))+import Distribution.Simple.Utils (ordNub)+import GHC.Generics (Generic)++-- | 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 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 view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Solver.Types.Settings+    ( ReorderGoals(..)+    , IndependentGoals(..)+    , AvoidReinstalls(..)+    , ShadowPkgs(..)+    , StrongFlags(..)+    , AllowBootLibInstalls(..)+    , EnableBackjumping(..)+    , CountConflicts(..)+    , SolveExecutables(..)+    ) where++import Distribution.Simple.Setup ( BooleanFlag(..) )+import Distribution.Compat.Binary (Binary(..))+import GHC.Generics (Generic)++newtype ReorderGoals = ReorderGoals Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype CountConflicts = CountConflicts 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)++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 IndependentGoals+instance Binary AvoidReinstalls+instance Binary ShadowPkgs+instance Binary StrongFlags+instance Binary AllowBootLibInstalls+instance Binary SolveExecutables
+ Distribution/Solver/Types/SolverId.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverId+    ( SolverId(..)+    )++where++import Distribution.Compat.Binary (Binary(..))+import Distribution.Package (PackageId, Package(..), UnitId)+import GHC.Generics (Generic)++-- | 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 Show SolverId where+    show = show . solverSrcId++instance Package SolverId where+  packageId = solverSrcId
+ Distribution/Solver/Types/SolverPackage.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverPackage+    ( SolverPackage(..)+    ) where++import Distribution.Compat.Binary (Binary(..))+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+import GHC.Generics (Generic)++-- | 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 Package (SolverPackage loc) where+  packageId = packageId . solverPkgSource
+ Distribution/Solver/Types/SourcePackage.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Distribution.Solver.Types.SourcePackage+    ( PackageDescriptionOverride+    , SourcePackage(..)+    ) where++import Distribution.Package+         ( PackageId, Package(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..) )++import Data.ByteString.Lazy (ByteString)+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))+import Data.Typeable++-- | A package description along with the location of the package sources.+--+data SourcePackage loc = SourcePackage {+    packageInfoId        :: PackageId,+    packageDescription   :: GenericPackageDescription,+    packageSource        :: loc,+    packageDescrOverride :: PackageDescriptionOverride+  }+  deriving (Eq, Show, Generic, Typeable)++instance (Binary loc) => Binary (SourcePackage loc)++instance Package (SourcePackage a) where packageId = packageInfoId++-- | 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 view
@@ -0,0 +1,14 @@+module Distribution.Solver.Types.Variable where++import Distribution.Solver.Types.OptionalStanza++import Distribution.PackageDescription (FlagName)++-- | Variables used by the dependency solver. This type is similar to the+-- internal 'Var' type, except that flags and stanzas are associated with+-- package names instead of package instances.+data Variable qpn =+    PackageVar qpn+  | FlagVar qpn FlagName+  | StanzaVar qpn OptionalStanza+  deriving Eq
LICENSE view
@@ -1,8 +1,5 @@-Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson,-                         Lemmih, Paolo Martini, Don Stewart,-                         Duncan Coutts+Copyright (c) 2003-2017, Cabal Development Team.+See the AUTHORS file for the full list of copyright holders. All rights reserved.  Redistribution and use in source and binary forms, with or without
Main.hs view
@@ -19,1305 +19,1206 @@          ( GlobalFlags(..), globalCommand, withRepoContext          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand-         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)-         , buildCommand, replCommand, testCommand, benchmarkCommand-         , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand, uninstallCommand-         , FetchFlags(..), fetchCommand-         , FreezeFlags(..), freezeCommand-         , genBoundsCommand-         , GetFlags(..), getCommand, unpackCommand-         , checkCommand-         , formatCommand-         , updateCommand-         , ListFlags(..), listCommand-         , InfoFlags(..), infoCommand-         , UploadFlags(..), uploadCommand-         , ReportFlags(..), reportCommand-         , runCommand-         , InitFlags(initVerbosity), initCommand-         , SDistFlags(..), SDistExFlags(..), sdistCommand-         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand-         , ActAsSetupFlags(..), actAsSetupCommand-         , SandboxFlags(..), sandboxCommand-         , ExecFlags(..), execCommand-         , UserConfigFlags(..), userConfigCommand-         , reportCommand-         , manpageCommand-         )-import Distribution.Simple.Setup-         ( HaddockFlags(..), haddockCommand, defaultHaddockFlags-         , HscolourFlags(..), hscolourCommand-         , ReplFlags(..)-         , CopyFlags(..), copyCommand-         , RegisterFlags(..), registerCommand-         , CleanFlags(..), cleanCommand-         , TestFlags(..), BenchmarkFlags(..)-         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag-         , configAbsolutePaths-         )--import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Config-         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff-         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )-import Distribution.Client.Targets-         ( readUserTargets )-import qualified Distribution.Client.List as List-         ( list, info )--import qualified Distribution.Client.CmdConfigure as CmdConfigure-import qualified Distribution.Client.CmdBuild     as CmdBuild-import qualified Distribution.Client.CmdRepl      as CmdRepl--import Distribution.Client.Install            (install)-import Distribution.Client.Configure          (configure)-import Distribution.Client.Update             (update)-import Distribution.Client.Exec               (exec)-import Distribution.Client.Fetch              (fetch)-import Distribution.Client.Freeze             (freeze)-import Distribution.Client.GenBounds          (genBounds)-import Distribution.Client.Check as Check     (check)---import Distribution.Client.Clean            (clean)-import qualified Distribution.Client.Upload as Upload-import Distribution.Client.Run                (run, splitRunArgs)-import Distribution.Client.SrcDist            (sdist)-import Distribution.Client.Get                (get)-import Distribution.Client.Sandbox            (sandboxInit-                                              ,sandboxAddSource-                                              ,sandboxDelete-                                              ,sandboxDeleteSource-                                              ,sandboxListSources-                                              ,sandboxHcPkg-                                              ,dumpPackageEnvironment--                                              ,getSandboxConfigFilePath-                                              ,loadConfigOrSandboxConfig-                                              ,findSavedDistPref-                                              ,initPackageDBIfNeeded-                                              ,maybeWithSandboxDirOnSearchPath-                                              ,maybeWithSandboxPackageInfo-                                              ,WereDepsReinstalled(..)-                                              ,maybeReinstallAddSourceDeps-                                              ,tryGetIndexFilePath-                                              ,sandboxBuildDir-                                              ,updateSandboxConfigFileFlag-                                              ,updateInstallDirs--                                              ,configCompilerAux'-                                              ,getPersistOrConfigCompiler-                                              ,configPackageDB')-import Distribution.Client.Sandbox.PackageEnvironment-                                              (setPackageDB-                                              ,userPackageEnvironmentFile)-import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)-import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)-import Distribution.Client.Tar                (createTarGzFile)-import Distribution.Client.Types              (Password (..))-import Distribution.Client.Init               (initCabal)-import Distribution.Client.Manpage            (manpage)-import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade-import Distribution.Client.Utils              (determineNumJobs-#if defined(mingw32_HOST_OS)-                                              ,relaxEncodingErrors-#endif-                                              ,existsAndIsMoreRecentThan)--import Distribution.Package (packageId)-import Distribution.PackageDescription-         ( BuildType(..), Executable(..), buildable )-import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.PackageDescription.PrettyPrint-         ( writeGenericPackageDescription )-import qualified Distribution.Simple as Simple-import qualified Distribution.Make as Make-import Distribution.Simple.Build-         ( startInterpreter )-import Distribution.Simple.Command-         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)-         , CommandType(..), commandsRun, commandAddAction, hiddenCommand-         , commandFromSpec)-import Distribution.Simple.Compiler-         ( Compiler(..) )-import Distribution.Simple.Configure-         ( checkPersistBuildConfigOutdated, configCompilerAuxEx-         , ConfigStateFileError(..), localBuildInfoFile-         , getPersistBuildConfig, tryGetPersistBuildConfig )-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Program (defaultProgramConfiguration-                                   ,configureAllKnownPrograms-                                   ,simpleProgramInvocation-                                   ,getProgramInvocationOutput)-import Distribution.Simple.Program.Db (reconfigurePrograms)-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Utils-         ( cabalVersion, die, notice, info, topHandler-         , findPackageDesc, tryFindPackageDesc )-import Distribution.Text-         ( display )-import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )-import Distribution.Version-         ( Version(..), orLaterVersion )-import qualified Paths_cabal_install (version)--import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure, exitSuccess)-import System.FilePath          ( dropExtension, splitExtension-                                , takeExtension, (</>), (<.>))-import System.IO                ( BufferMode(LineBuffering), hSetBuffering-#ifdef mingw32_HOST_OS-                                , stderr-#endif-                                , stdout )-import System.Directory         (doesFileExist, getCurrentDirectory)-import Data.List                (intercalate)-import Data.Maybe               (listToMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid              (Monoid(..))-import Control.Applicative      (pure, (<$>))-#endif-import Control.Exception        (SomeException(..), try)-import Control.Monad            (when, unless, void)---- | Entry point----main :: IO ()-main = do-  -- Enable line buffering so that we can get fast feedback even when piped.-  -- This is especially important for CI and build systems.-  hSetBuffering stdout LineBuffering-  -- The default locale encoding for Windows CLI is not UTF-8 and printing-  -- Unicode characters to it will fail unless we relax the handling of encoding-  -- errors when writing to stderr and stdout.-#ifdef mingw32_HOST_OS-  relaxEncodingErrors stdout-  relaxEncodingErrors stderr-#endif-  getArgs >>= mainWorker--mainWorker :: [String] -> IO ()-mainWorker args = topHandler $-  case commandsRun (globalCommand commands) commands args of-    CommandHelp   help                 -> printGlobalHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (globalFlags, commandParse)  ->-      case commandParse of-        _ | fromFlagOrDefault False (globalVersion globalFlags)-            -> printVersion-          | fromFlagOrDefault False (globalNumericVersion globalFlags)-            -> printNumericVersion-        CommandHelp     help           -> printCommandHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> do-          globalFlags' <- updateSandboxConfigFileFlag globalFlags-          action globalFlags'--  where-    printCommandHelp help = do-      pname <- getProgName-      putStr (help pname)-    printGlobalHelp help = do-      pname <- getProgName-      configFile <- defaultConfigFile-      putStr (help pname)-      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"-            ++ "  " ++ configFile ++ "\n"-      exists <- doesFileExist configFile-      when (not exists) $-          putStrLn $ "This file will be generated with sensible "-                  ++ "defaults if you run 'cabal update'."-    printOptionsList = putStr . unlines-    printErrors errs = die $ intercalate "\n" errs-    printNumericVersion = putStrLn $ display Paths_cabal_install.version-    printVersion        = putStrLn $ "cabal-install version "-                                  ++ display Paths_cabal_install.version-                                  ++ "\ncompiled using version "-                                  ++ display cabalVersion-                                  ++ " of the Cabal library "--    commands = map commandFromSpec commandSpecs-    commandSpecs =-      [ regularCmd installCommand installAction-      , regularCmd updateCommand updateAction-      , regularCmd listCommand listAction-      , regularCmd infoCommand infoAction-      , regularCmd fetchCommand fetchAction-      , regularCmd freezeCommand freezeAction-      , regularCmd getCommand getAction-      , hiddenCmd  unpackCommand unpackAction-      , regularCmd checkCommand checkAction-      , regularCmd sdistCommand sdistAction-      , regularCmd uploadCommand uploadAction-      , regularCmd reportCommand reportAction-      , regularCmd runCommand runAction-      , regularCmd initCommand initAction-      , regularCmd configureExCommand configureAction-      , regularCmd buildCommand buildAction-      , regularCmd replCommand replAction-      , regularCmd sandboxCommand sandboxAction-      , regularCmd haddockCommand haddockAction-      , regularCmd execCommand execAction-      , regularCmd userConfigCommand userConfigAction-      , regularCmd cleanCommand cleanAction-      , regularCmd genBoundsCommand genBoundsAction-      , wrapperCmd copyCommand copyVerbosity copyDistPref-      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref-      , wrapperCmd registerCommand regVerbosity regDistPref-      , regularCmd testCommand testAction-      , regularCmd benchmarkCommand benchmarkAction-      , hiddenCmd  uninstallCommand uninstallAction-      , hiddenCmd  formatCommand formatAction-      , hiddenCmd  upgradeCommand upgradeAction-      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction-      , hiddenCmd  actAsSetupCommand actAsSetupAction-      , hiddenCmd  manpageCommand (manpageAction commandSpecs)--      , hiddenCmd  installCommand { commandName = "new-configure" }-                                  CmdConfigure.configureAction-      , hiddenCmd  installCommand { commandName = "new-build" }-                                  CmdBuild.buildAction-      , hiddenCmd  installCommand { commandName = "new-repl" }-                                  CmdRepl.replAction-      ]--type Action = GlobalFlags -> IO ()--regularCmd :: CommandUI flags -> (flags -> [String] -> action)-           -> CommandSpec action-regularCmd ui action =-  CommandSpec ui ((flip commandAddAction) action) NormalCommand--hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)-          -> CommandSpec action-hiddenCmd ui action =-  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))-  HiddenCommand--wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)-           -> (flags -> Flag String) -> CommandSpec Action-wrapperCmd ui verbosity distPref =-  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand--wrapperAction :: Monoid flags-              => CommandUI flags-              -> (flags -> Flag Verbosity)-              -> (flags -> Flag String)-              -> Command Action-wrapperAction command verbosityFlag distPrefFlag =-  commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do-    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-    let config = either (\(SomeException _) -> mempty) snd load-    distPref <- findSavedDistPref config (distPrefFlag flags)-    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }-    setupWrapper verbosity setupScriptOptions Nothing-                 command (const flags) extraArgs--configureAction :: (ConfigFlags, ConfigExFlags)-                -> [String] -> Action-configureAction (configFlags, configExFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)--  (useSandbox, config) <- fmap-                          (updateInstallDirs (configUserInstall configFlags))-                          (loadConfigOrSandboxConfig verbosity globalFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAuxEx configFlags'--  -- If we're working inside a sandbox and the user has set the -w option, we-  -- may need to create a sandbox-local package DB for this compiler and add a-  -- timestamp record for this compiler to the timestamp file.-  let configFlags''  = case useSandbox of-        NoSandbox               -> configFlags'-        (UseSandbox sandboxDir) -> setPackageDB sandboxDir-                                   comp platform configFlags'--  whenUsingSandbox useSandbox $ \sandboxDir -> do-    initPackageDBIfNeeded verbosity configFlags'' comp conf-    -- NOTE: We do not write the new sandbox package DB location to-    -- 'cabal.sandbox.config' here because 'configure -w' must not affect-    -- subsequent 'install' (for UI compatibility with non-sandboxed mode).--    indexFile     <- tryGetIndexFilePath config-    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-      (compilerId comp) platform--  maybeWithSandboxDirOnSearchPath useSandbox $-   withRepoContext verbosity globalFlags' $ \repoContext ->-    configure verbosity-              (configPackageDB' configFlags'')-              repoContext-              comp platform conf configFlags'' configExFlags' extraArgs--buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)--  -- Calls 'configureAction' to do the real work, so nothing special has to be-  -- done to support sandboxes.-  (useSandbox, config, distPref) <- reconfigure verbosity-                                    (buildDistPref buildFlags)-                                    mempty [] globalFlags noAddSource-                                    (buildNumJobs buildFlags) (const Nothing)--  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags extraArgs----- | Actually do the work of building the package. This is separate from--- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke--- 'reconfigure' twice.-build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()-build verbosity config distPref buildFlags extraArgs =-  setupWrapper verbosity setupOptions Nothing-               (Cabal.buildCommand progConf) mkBuildFlags extraArgs-  where-    progConf     = defaultProgramConfiguration-    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }--    mkBuildFlags version = filterBuildFlags version config buildFlags'-    buildFlags' = buildFlags-      { buildVerbosity = toFlag verbosity-      , buildDistPref  = toFlag distPref-      }---- | Make sure that we don't pass new flags to setup scripts compiled against--- old versions of Cabal.-filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags-filterBuildFlags version config buildFlags-  | version >= Version [1,19,1] [] = buildFlags_latest-  -- Cabal < 1.19.1 doesn't support 'build -j'.-  | otherwise                      = buildFlags_pre_1_19_1-  where-    buildFlags_pre_1_19_1 = buildFlags {-      buildNumJobs = NoFlag-      }-    buildFlags_latest     = buildFlags {-      -- Take the 'jobs' setting '~/.cabal/config' into account.-      buildNumJobs = Flag . Just . determineNumJobs $-                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)-      }-    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config-    numJobsCmdLineFlag = buildNumJobs buildFlags---replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action-replAction (replFlags, buildExFlags) extraArgs globalFlags = do-  cwd     <- getCurrentDirectory-  pkgDesc <- findPackageDesc cwd-  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc-  where-    verbosity = fromFlagOrDefault normal (replVerbosity replFlags)--    -- There is a .cabal file in the current directory: start a REPL and load-    -- the project's modules.-    onPkgDesc = do-      let noAddSource = case replReload replFlags of-            Flag True -> SkipAddSourceDepsCheck-            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck-                         (buildOnly buildExFlags)-      -- Calls 'configureAction' to do the real work, so nothing special has to-      -- be done to support sandboxes.-      (useSandbox, _config, distPref) <--        reconfigure verbosity (replDistPref replFlags)-                    mempty [] globalFlags noAddSource NoFlag-                    (const Nothing)-      let progConf     = defaultProgramConfiguration-          setupOptions = defaultSetupScriptOptions-            { useCabalVersion = orLaterVersion $ Version [1,18,0] []-            , useDistPref     = distPref-            }-          replFlags'   = replFlags-            { replVerbosity = toFlag verbosity-            , replDistPref  = toFlag distPref-            }--      maybeWithSandboxDirOnSearchPath useSandbox $-        setupWrapper verbosity setupOptions Nothing-        (Cabal.replCommand progConf) (const replFlags') extraArgs--    -- No .cabal file in the current directory: just start the REPL (possibly-    -- using the sandbox package DB).-    onNoPkgDesc = do-      (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-      let configFlags = savedConfigureFlags config-      (comp, platform, programDb) <- configCompilerAux' configFlags-      programDb' <- reconfigurePrograms verbosity-                                        (replProgramPaths replFlags)-                                        (replProgramArgs replFlags)-                                        programDb-      startInterpreter verbosity programDb' comp platform-                       (configPackageDB' configFlags)---- | 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 :: Verbosity    -- ^ Verbosity setting-            -> Flag FilePath  -- ^ \"dist\" prefix-            -> ConfigFlags  -- ^ Additional config flags to set. These flags-                            -- will be 'mappend'ed to the last used or-                            -- default 'ConfigFlags' as appropriate, so-                            -- this value should be 'mempty' with only the-                            -- required flags set. The required verbosity-                            -- and \"dist\" prefix flags will be set-                            -- automatically because they are always-                            -- required; therefore, it is not necessary to-                            -- set them here.-            -> [String]     -- ^ Extra arguments-            -> GlobalFlags  -- ^ Global flags-            -> SkipAddSourceDepsCheck-                            -- ^ Should we skip the timestamp check for modified-                            -- add-source dependencies?-            -> Flag (Maybe Int)-                            -- ^ -j flag for reinstalling add-source deps.-            -> (ConfigFlags -> Maybe String)-                            -- ^ Check that the required flags are set in-                            -- the last used 'ConfigFlags'. If the required-                            -- flags are not set, provide a message to the-                            -- user explaining the reason for-                            -- reconfiguration. Because the correct \"dist\"-                            -- prefix setting is always required, it is checked-                            -- automatically; this function need not check-                            -- for it.-            -> IO (UseSandbox, SavedConfig, FilePath)-reconfigure verbosity flagDistPref addConfigFlags extraArgs globalFlags-            skipAddSourceDepsCheck numJobsFlag    checkFlags = do-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config flagDistPref-  eLbi <- tryGetPersistBuildConfig distPref-  config' <- case eLbi of-    Left err  -> onNoBuildConfig (useSandbox, config) distPref err-    Right lbi -> onBuildConfig (useSandbox, config) distPref lbi-  return (useSandbox, config', distPref)--  where--    -- We couldn't load the saved package config file.-    ---    -- If we're in a sandbox: add-source deps don't have to be reinstalled-    -- (since we don't know the compiler & platform).-    onNoBuildConfig :: (UseSandbox, SavedConfig) -> FilePath-                    -> ConfigStateFileError -> IO SavedConfig-    onNoBuildConfig (_, config) distPref err = do-      let msg = case err of-            ConfigStateFileMissing -> "Package has never been configured."-            ConfigStateFileNoParse -> "Saved package config file seems "-                                      ++ "to be corrupt."-            _ -> show err-      case err of-        -- Note: the build config could have been generated by a custom setup-        -- script built against a different Cabal version, so it's crucial that-        -- we ignore the bad version error here.-        ConfigStateFileBadVersion _ _ _ -> info verbosity msg-        _                               -> do-          let distVerbFlags = mempty-                { configVerbosity = toFlag verbosity-                , configDistPref  = toFlag distPref-                }-              defaultFlags = mappend addConfigFlags distVerbFlags-          notice verbosity-            $ msg ++ " Configuring with default flags." ++ configureManually-          configureAction (defaultFlags, defaultConfigExFlags)-            extraArgs globalFlags-      return config--    -- Package has been configured, but the configuration may be out of-    -- date or required flags may not be set.-    ---    -- If we're in a sandbox: reinstall the modified add-source deps and-    -- force reconfigure if we did.-    onBuildConfig :: (UseSandbox, SavedConfig) -> FilePath-                  -> LBI.LocalBuildInfo -> IO SavedConfig-    onBuildConfig (useSandbox, config) distPref lbi = do-      let configFlags = LBI.configFlags lbi-          distVerbFlags = mempty-            { configVerbosity = toFlag verbosity-            , configDistPref  = toFlag distPref-            }-          flags       = mconcat [configFlags, addConfigFlags, distVerbFlags]--      -- Was the sandbox created after the package was already configured? We-      -- may need to skip reinstallation of add-source deps and force-      -- reconfigure.-      let buildConfig       = localBuildInfoFile distPref-      sandboxConfig        <- getSandboxConfigFilePath globalFlags-      isSandboxConfigNewer <--        sandboxConfig `existsAndIsMoreRecentThan` buildConfig--      let skipAddSourceDepsCheck'-            | isSandboxConfigNewer = SkipAddSourceDepsCheck-            | otherwise            = skipAddSourceDepsCheck--      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $-        info verbosity "Skipping add-source deps check..."--      let (_, config') = updateInstallDirs-                         (configUserInstall flags)-                         (useSandbox, config)--      depsReinstalled <--        case skipAddSourceDepsCheck' of-          DontSkipAddSourceDepsCheck ->-            maybeReinstallAddSourceDeps-              verbosity numJobsFlag flags globalFlags-              (useSandbox, config')-          SkipAddSourceDepsCheck -> do-            return NoDepsReinstalled--      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need-      -- to force reconfigure. Note that it's possible to use @cabal.config@-      -- even without sandboxes.-      isUserPackageEnvironmentFileNewer <--        userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig--      -- Determine whether we need to reconfigure and which message to show to-      -- the user if that is the case.-      mMsg <- determineMessageToShow distPref lbi configFlags-                                     depsReinstalled isSandboxConfigNewer-                                     isUserPackageEnvironmentFileNewer-      case mMsg of--        -- No message for the user indicates that reconfiguration-        -- is not required.-        Nothing -> return config'--        -- Show the message and reconfigure.-        Just msg -> do-          notice verbosity msg-          configureAction (flags, defaultConfigExFlags)-            extraArgs globalFlags-          return config'--    -- Determine what message, if any, to display to the user if reconfiguration-    -- is required.-    determineMessageToShow :: FilePath -> LBI.LocalBuildInfo -> ConfigFlags-                            -> WereDepsReinstalled -> Bool -> Bool-                            -> IO (Maybe String)-    determineMessageToShow _ _   _           _               True  _     =-      -- The sandbox was created after the package was already configured.-      return $! Just $! sandboxConfigNewerMessage--    determineMessageToShow _ _   _           _               False True  =-      -- The user package environment file was modified.-      return $! Just $! userPackageEnvironmentFileModifiedMessage--    determineMessageToShow distPref lbi configFlags depsReinstalled-                           False False = do-      let savedDistPref = fromFlagOrDefault-                          (useDistPref defaultSetupScriptOptions)-                          (configDistPref configFlags)-      case depsReinstalled of-        ReinstalledSomeDeps ->-          -- Some add-source deps were reinstalled.-          return $! Just $! reinstalledDepsMessage-        NoDepsReinstalled ->-          case checkFlags configFlags of-            -- Flag required by the caller is not set.-            Just msg -> return $! Just $! msg ++ configureManually--            Nothing-              -- Required "dist" prefix is not set.-              | savedDistPref /= distPref ->-                return $! Just distPrefMessage--              -- All required flags are set, but the configuration-              -- may be outdated.-              | otherwise -> case LBI.pkgDescrFile lbi of-                Nothing -> return Nothing-                Just pdFile -> do-                  outdated <- checkPersistBuildConfigOutdated-                              distPref pdFile-                  return $! if outdated-                            then Just $! outdatedMessage pdFile-                            else Nothing--    reconfiguringMostRecent = " Re-configuring with most recently used options."-    configureManually       = " If this fails, please run configure manually."-    sandboxConfigNewerMessage =-        "The sandbox was created after the package was already configured."-        ++ reconfiguringMostRecent-        ++ configureManually-    userPackageEnvironmentFileModifiedMessage =-        "The user package environment file ('"-        ++ userPackageEnvironmentFile ++ "') was modified."-        ++ reconfiguringMostRecent-        ++ configureManually-    distPrefMessage =-        "Package previously configured with different \"dist\" prefix."-        ++ reconfiguringMostRecent-        ++ configureManually-    outdatedMessage pdFile =-        pdFile ++ " has been changed."-        ++ reconfiguringMostRecent-        ++ configureManually-    reinstalledDepsMessage =-        "Some add-source dependencies have been reinstalled."-        ++ reconfiguringMostRecent-        ++ configureManually--installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> Action-installAction (configFlags, _, installFlags, _) _ globalFlags-  | fromFlagOrDefault False (installOnly installFlags) = do-      let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-      load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-      let config = either (\(SomeException _) -> mempty) snd load-      distPref <- findSavedDistPref config (configDistPref configFlags)-      let setupOpts = defaultSetupScriptOptions { useDistPref = distPref }-      setupWrapper verbosity setupOpts Nothing installCommand (const mempty) []--installAction (configFlags, configExFlags, installFlags, haddockFlags)-              extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- fmap-                          (updateInstallDirs (configUserInstall configFlags))-                          (loadConfigOrSandboxConfig verbosity globalFlags)-  targets <- readUserTargets verbosity extraArgs--  -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to-  -- 'configure' when run inside a sandbox.  Right now, running-  ---  -- $ cabal sandbox init && cabal configure -w /path/to/ghc-  --   && cabal build && cabal install-  ---  -- performs the compilation twice unless you also pass -w to 'install'.-  -- However, this is the same behaviour that 'cabal install' has in the normal-  -- mode of operation, so we stick to it for consistency.--  let sandboxDistPref = case useSandbox of-        NoSandbox             -> NoFlag-        UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-  distPref <- findSavedDistPref config-              (configDistPref configFlags `mappend` sandboxDistPref)--  let configFlags'    = maybeForceTests installFlags' $-                        savedConfigureFlags   config `mappend`-                        configFlags { configDistPref = toFlag distPref }-      configExFlags'  = defaultConfigExFlags         `mappend`-                        savedConfigureExFlags config `mappend` configExFlags-      installFlags'   = defaultInstallFlags          `mappend`-                        savedInstallFlags     config `mappend` installFlags-      haddockFlags'   = defaultHaddockFlags          `mappend`-                        savedHaddockFlags     config `mappend`-                        haddockFlags { haddockDistPref = toFlag distPref }-      globalFlags'    = savedGlobalFlags      config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags'-  -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the-  -- future.-  conf' <- configureAllKnownPrograms verbosity conf--  -- If we're working inside a sandbox and the user has set the -w option, we-  -- may need to create a sandbox-local package DB for this compiler and add a-  -- timestamp record for this compiler to the timestamp file.-  configFlags'' <- case useSandbox of-    NoSandbox               -> configAbsolutePaths $ configFlags'-    (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform-                                                     configFlags'--  whenUsingSandbox useSandbox $ \sandboxDir -> do-    initPackageDBIfNeeded verbosity configFlags'' comp conf'--    indexFile     <- tryGetIndexFilePath config-    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile-      (compilerId comp) platform--  -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means-  -- that 'cabal install some-package' inside a sandbox will sometimes reinstall-  -- modified add-source deps, even if they are not among the dependencies of-  -- 'some-package'. This can also prevent packages that depend on older-  -- versions of add-source'd packages from building (see #1362).-  maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->-                              maybeWithSandboxDirOnSearchPath useSandbox $-    withRepoContext verbosity globalFlags' $ \repoContext ->-      install verbosity-              (configPackageDB' configFlags'')-              repoContext-              comp platform conf'-              useSandbox mSandboxPkgInfo-              globalFlags' configFlags'' configExFlags'-              installFlags' haddockFlags'-              targets--    where-      -- '--run-tests' implies '--enable-tests'.-      maybeForceTests installFlags' configFlags' =-        if fromFlagOrDefault False (installRunTests installFlags')-        then configFlags' { configTests = toFlag True }-        else configFlags'--testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags-           -> IO ()-testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-      addConfigFlags = mempty { configTests = toFlag True }-      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck-                       (buildOnly buildExFlags)-      buildFlags'    = buildFlags-                       { buildVerbosity = testVerbosity testFlags }-      checkFlags flags-        | fromFlagOrDefault False (configTests flags) = Nothing-        | otherwise  = Just "Re-configuring with test suites enabled."--  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (testDistPref testFlags)-                addConfigFlags [] globalFlags noAddSource-                (buildNumJobs buildFlags') checkFlags-  let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-      testFlags'     = testFlags { testDistPref = toFlag distPref }--  -- The package was just configured, so the LBI must be available.-  names <- componentNamesFromLBI verbosity distPref "test suites"-             (\c -> case c of { LBI.CTest{} -> True; _ -> False })-  let extraArgs'-        | null extraArgs = case names of-          ComponentNamesUnknown -> []-          ComponentNames names' -> [ name | LBI.CTestName name <- names' ]-        | otherwise      = extraArgs--  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags' extraArgs'--  maybeWithSandboxDirOnSearchPath useSandbox $-    setupWrapper verbosity setupOptions Nothing-    Cabal.testCommand (const testFlags') extraArgs'--data ComponentNames = ComponentNamesUnknown-                    | ComponentNames [LBI.ComponentName]---- | Return the names of all buildable components matching a given predicate.-componentNamesFromLBI :: Verbosity -> FilePath -> String-                         -> (LBI.Component -> Bool)-                         -> IO ComponentNames-componentNamesFromLBI verbosity distPref targetsDescr compPred = do-  eLBI <- tryGetPersistBuildConfig distPref-  case eLBI of-    Left err -> case err of-      -- Note: the build config could have been generated by a custom setup-      -- script built against a different Cabal version, so it's crucial that-      -- we ignore the bad version error here.-      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown-      _                               -> die (show err)-    Right lbi -> do-      let pkgDescr = LBI.localPkgDescr lbi-          names    = map LBI.componentName-                     . filter (buildable . LBI.componentBuildInfo)-                     . filter compPred $-                     LBI.pkgComponents pkgDescr-      if null names-        then do notice verbosity $ "Package has no buildable "-                  ++ targetsDescr ++ "."-                exitSuccess -- See #3215.--        else return $! (ComponentNames names)--benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)-                   -> [String] -> GlobalFlags-                   -> IO ()-benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)-                extraArgs globalFlags = do-  let verbosity      = fromFlagOrDefault normal-                       (benchmarkVerbosity benchmarkFlags)-      addConfigFlags = mempty { configBenchmarks = toFlag True }-      buildFlags'    = buildFlags-                       { buildVerbosity = benchmarkVerbosity benchmarkFlags }-      checkFlags flags-        | fromFlagOrDefault False (configBenchmarks flags) = Nothing-        | otherwise = Just "Re-configuring with benchmarks enabled."-      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck-                      (buildOnly buildExFlags)--  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (benchmarkDistPref benchmarkFlags)-                addConfigFlags [] globalFlags noAddSource-                (buildNumJobs buildFlags') checkFlags-  let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-      benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }--  -- The package was just configured, so the LBI must be available.-  names <- componentNamesFromLBI verbosity distPref "benchmarks"-           (\c -> case c of { LBI.CBench{} -> True; _ -> False; })-  let extraArgs'-        | null extraArgs = case names of-          ComponentNamesUnknown -> []-          ComponentNames names' -> [name | LBI.CBenchName name <- names']-        | otherwise      = extraArgs--  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags' extraArgs'--  maybeWithSandboxDirOnSearchPath useSandbox $-    setupWrapper verbosity setupOptions Nothing-    Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'--haddockAction :: HaddockFlags -> [String] -> Action-haddockAction haddockFlags extraArgs globalFlags = do-  let verbosity = fromFlag (haddockVerbosity haddockFlags)-  (_useSandbox, config, distPref) <--    reconfigure verbosity (haddockDistPref haddockFlags)-                mempty [] globalFlags DontSkipAddSourceDepsCheck-                NoFlag (const Nothing)-  let haddockFlags' = defaultHaddockFlags      `mappend`-                      savedHaddockFlags config `mappend`-                      haddockFlags { haddockDistPref = toFlag distPref }-      setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }-  setupWrapper verbosity setupScriptOptions Nothing-    haddockCommand (const haddockFlags') extraArgs-  when (haddockForHackage haddockFlags == Flag True) $ do-    pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)-    let dest = distPref </> name <.> "tar.gz"-        name = display (packageId pkg) ++ "-docs"-        docDir = distPref </> "doc" </> "html"-    createTarGzFile dest docDir name-    notice verbosity $ "Documentation tarball created: " ++ dest--cleanAction :: CleanFlags -> [String] -> Action-cleanAction cleanFlags extraArgs globalFlags = do-  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-  let config = either (\(SomeException _) -> mempty) snd load-  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)-  let setupScriptOptions = defaultSetupScriptOptions-                           { useDistPref = distPref-                           , useWin32CleanHack = True-                           }-      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }-  setupWrapper verbosity setupScriptOptions Nothing-               cleanCommand (const cleanFlags') extraArgs-  where-    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)--listAction :: ListFlags -> [String] -> Action-listAction listFlags extraArgs globalFlags = do-  let verbosity = fromFlag (listVerbosity listFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags' = savedConfigureFlags config-      configFlags  = configFlags' {-        configPackageDBs = configPackageDBs configFlags'-                           `mappend` listPackageDBs listFlags-        }-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    List.list verbosity-       (configPackageDB' configFlags)-       repoContext-       comp-       conf-       listFlags-       extraArgs--infoAction :: InfoFlags -> [String] -> Action-infoAction infoFlags extraArgs globalFlags = do-  let verbosity = fromFlag (infoVerbosity infoFlags)-  targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags' = savedConfigureFlags config-      configFlags  = configFlags' {-        configPackageDBs = configPackageDBs configFlags'-                           `mappend` infoPackageDBs infoFlags-        }-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAuxEx configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    List.info verbosity-       (configPackageDB' configFlags)-       repoContext-       comp-       conf-       globalFlags'-       infoFlags-       targets--updateAction :: Flag Verbosity -> [String] -> Action-updateAction verbosityFlag extraArgs globalFlags = do-  unless (null extraArgs) $-    die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  let verbosity = fromFlag verbosityFlag-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    update verbosity repoContext--upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> Action-upgradeAction _ _ _ = die $-    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"- ++ "You can install the latest version of a package using 'cabal install'. "- ++ "The 'cabal upgrade' command has been removed because people found it "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."--fetchAction :: FetchFlags -> [String] -> Action-fetchAction fetchFlags extraArgs globalFlags = do-  let verbosity = fromFlag (fetchVerbosity fetchFlags)-  targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    fetch verbosity-        (configPackageDB' configFlags)-        repoContext-        comp platform conf globalFlags' fetchFlags-        targets--freezeAction :: FreezeFlags -> [String] -> Action-freezeAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags--  maybeWithSandboxPackageInfo verbosity configFlags globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->-                              maybeWithSandboxDirOnSearchPath useSandbox $-    withRepoContext verbosity globalFlags' $ \repoContext ->-      freeze verbosity-            (configPackageDB' configFlags)-            repoContext-            comp platform conf-            mSandboxPkgInfo-            globalFlags' freezeFlags--genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()-genBoundsAction freezeFlags _extraArgs globalFlags = do-  let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, platform, conf) <- configCompilerAux' configFlags--  maybeWithSandboxPackageInfo verbosity configFlags globalFlags'-                              comp platform conf useSandbox $ \mSandboxPkgInfo ->-                              maybeWithSandboxDirOnSearchPath useSandbox $-    withRepoContext verbosity globalFlags' $ \repoContext ->-      genBounds verbosity-            (configPackageDB' configFlags)-            repoContext-            comp platform conf-            mSandboxPkgInfo-            globalFlags' freezeFlags--uploadAction :: UploadFlags -> [String] -> Action-uploadAction uploadFlags extraArgs globalFlags = do-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-      tarfiles     = extraArgs-  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $-    die "the 'upload' command expects at least one .tar.gz archive."-  when (fromFlag (uploadCheck uploadFlags')-        && fromFlag (uploadDoc uploadFlags')) $-    die "--check and --doc cannot be used together."-  checkTarFiles extraArgs-  maybe_password <--    case uploadPasswordCmd uploadFlags'-    of Flag (xs:xss) -> Just . Password <$>-                        getProgramInvocationOutput verbosity-                        (simpleProgramInvocation xs xss)-       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'-  withRepoContext verbosity globalFlags' $ \repoContext -> do-    if fromFlag (uploadCheck uploadFlags')-    then do-      Upload.check verbosity repoContext tarfiles-    else if fromFlag (uploadDoc uploadFlags')-    then do-      when (length tarfiles > 1) $-       die $ "the 'upload' command can only upload documentation "-             ++ "for one package at a time."-      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles-      Upload.uploadDoc verbosity-                       repoContext-                       (flagToMaybe $ uploadUsername uploadFlags')-                       maybe_password-                       tarfile-    else do-      Upload.upload verbosity-                    repoContext-                    (flagToMaybe $ uploadUsername uploadFlags')-                    maybe_password-                    tarfiles-    where-    verbosity = fromFlag (uploadVerbosity uploadFlags)-    checkTarFiles tarfiles-      | not (null otherFiles)-      = die $ "the 'upload' command expects only .tar.gz archives: "-           ++ intercalate ", " otherFiles-      | otherwise = sequence_-                      [ do exists <- doesFileExist tarfile-                           unless exists $ die $ "file not found: " ++ tarfile-                      | tarfile <- tarfiles ]--      where otherFiles = filter (not . isTarGzFile) tarfiles-            isTarGzFile file = case splitExtension file of-              (file', ".gz") -> takeExtension file' == ".tar"-              _              -> False-    generateDocTarball config = do-      notice verbosity $-        "No documentation tarball specified. "-        ++ "Building a documentation tarball with default settings...\n"-        ++ "If you need to customise Haddock options, "-        ++ "run 'haddock --for-hackage' first "-        ++ "to generate a documentation tarball."-      haddockAction (defaultHaddockFlags { haddockForHackage = Flag True })-                    [] globalFlags-      distPref <- findSavedDistPref config NoFlag-      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)-      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"--checkAction :: Flag Verbosity -> [String] -> Action-checkAction verbosityFlag extraArgs _globalFlags = do-  unless (null extraArgs) $-    die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs-  allOk <- Check.check (fromFlag verbosityFlag)-  unless allOk exitFailure--formatAction :: Flag Verbosity -> [String] -> Action-formatAction verbosityFlag extraArgs _globalFlags = do-  let verbosity = fromFlag verbosityFlag-  path <- case extraArgs of-    [] -> do cwd <- getCurrentDirectory-             tryFindPackageDesc cwd-    (p:_) -> return p-  pkgDesc <- readPackageDescription verbosity path-  -- Uses 'writeFileAtomic' under the hood.-  writeGenericPackageDescription path pkgDesc--uninstallAction :: Flag Verbosity -> [String] -> Action-uninstallAction _verbosityFlag extraArgs _globalFlags = do-  let package = case extraArgs of-        p:_ -> p-        _   -> "PACKAGE_NAME"-  die $ "This version of 'cabal-install' does not support the 'uninstall' "-    ++ "operation. "-    ++ "It will likely be implemented at some point in the future; "-    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "-    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."---sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action-sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do-  unless (null extraArgs) $-    die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs-  let verbosity = fromFlag (sDistVerbosity sdistFlags)-  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)-  let config = either (\(SomeException _) -> mempty) snd load-  distPref <- findSavedDistPref config (sDistDistPref sdistFlags)-  let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }-  sdist sdistFlags' sdistExFlags--reportAction :: ReportFlags -> [String] -> Action-reportAction reportFlags extraArgs globalFlags = do-  unless (null extraArgs) $-    die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs--  let verbosity = fromFlag (reportVerbosity reportFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-      reportFlags' = savedReportFlags config `mappend` reportFlags--  withRepoContext verbosity globalFlags' $ \repoContext ->-   Upload.report verbosity repoContext-    (flagToMaybe $ reportUsername reportFlags')-    (flagToMaybe $ reportPassword reportFlags')--runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action-runAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck-                    (buildOnly buildExFlags)--  -- reconfigure also checks if we're in a sandbox and reinstalls add-source-  -- deps if needed.-  (useSandbox, config, distPref) <--    reconfigure verbosity (buildDistPref buildFlags) mempty []-                globalFlags noAddSource (buildNumJobs buildFlags)-                (const Nothing)--  lbi <- getPersistBuildConfig distPref-  (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs--  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags ["exe:" ++ exeName exe]--  maybeWithSandboxDirOnSearchPath useSandbox $-    run verbosity lbi exe exeArgs--getAction :: GetFlags -> [String] -> Action-getAction getFlags extraArgs globalFlags = do-  let verbosity = fromFlag (getVerbosity getFlags)-  targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->-   get verbosity-    repoContext-    globalFlags'-    getFlags-    targets--unpackAction :: GetFlags -> [String] -> Action-unpackAction getFlags extraArgs globalFlags = do-  getAction getFlags extraArgs globalFlags--initAction :: InitFlags -> [String] -> Action-initAction initFlags extraArgs globalFlags = do-  when (extraArgs /= []) $-    die $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs-  let verbosity = fromFlag (initVerbosity initFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                           (globalFlags { globalRequireSandbox = Flag False })-  let configFlags  = savedConfigureFlags config-  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, _, conf) <- configCompilerAux' configFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    initCabal verbosity-            (configPackageDB' configFlags)-            repoContext-            comp-            conf-            initFlags--sandboxAction :: SandboxFlags -> [String] -> Action-sandboxAction sandboxFlags extraArgs globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  case extraArgs of-    -- Basic sandbox commands.-    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags-    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags-    ("add-source":extra) -> do-        when (noExtraArgs extra) $-          die "The 'sandbox add-source' command expects at least one argument"-        sandboxAddSource verbosity extra sandboxFlags globalFlags-    ("delete-source":extra) -> do-        when (noExtraArgs extra) $-          die ("The 'sandbox delete-source' command expects " ++-              "at least one argument")-        sandboxDeleteSource verbosity extra sandboxFlags globalFlags-    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags--    -- More advanced commands.-    ("hc-pkg":extra) -> do-        when (noExtraArgs extra) $-            die $ "The 'sandbox hc-pkg' command expects at least one argument"-        sandboxHcPkg verbosity sandboxFlags globalFlags extra-    ["buildopts"] -> die "Not implemented!"--    -- Hidden commands.-    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags--    -- Error handling.-    [] -> die $ "Please specify a subcommand (see 'help sandbox')"-    _  -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs--  where-    noExtraArgs = (<1) . length--execAction :: ExecFlags -> [String] -> Action-execAction execFlags extraArgs globalFlags = do-  let verbosity = fromFlag (execVerbosity execFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-  let configFlags = savedConfigureFlags config-  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags-  exec verbosity useSandbox comp platform conf extraArgs--userConfigAction :: UserConfigFlags -> [String] -> Action-userConfigAction ucflags extraArgs globalFlags = do-  let verbosity = fromFlag (userConfigVerbosity ucflags)-      force     = fromFlag (userConfigForce ucflags)-  case extraArgs of-    ("init":_) -> do-      path       <- configFile-      fileExists <- doesFileExist path-      if (not fileExists || (fileExists && force))-      then void $ createDefaultConfigFile verbosity path-      else die $ path ++ " already exists."-    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags-    ("update":_) -> userConfigUpdate verbosity globalFlags-    -- Error handling.-    [] -> die $ "Please specify a subcommand (see 'help user-config')"-    _  -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs-  where configFile = getConfigFilePath (globalConfigFile globalFlags)---- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.----win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action-win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do-  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)-  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path-win32SelfUpgradeAction _ _ _ = return ()---- | Used as an entry point when cabal-install needs to invoke itself--- as a setup script. This can happen e.g. when doing parallel builds.----actAsSetupAction :: ActAsSetupFlags -> [String] -> Action-actAsSetupAction actAsSetupFlags args _globalFlags =-  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)-  in case bt of-    Simple    -> Simple.defaultMainArgs args-    Configure -> Simple.defaultMainWithHooksArgs-                  Simple.autoconfUserHooks args-    Make      -> Make.defaultMainArgs args-    Custom               -> error "actAsSetupAction Custom"-    (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"--manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action-manpageAction commands _ extraArgs _ = do-  unless (null extraArgs) $-    die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs+         , reconfigureCommand+         , configCompilerAux', configPackageDB'+         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+         , buildCommand, replCommand, testCommand, benchmarkCommand+         , InstallFlags(..), defaultInstallFlags+         , installCommand, upgradeCommand, uninstallCommand+         , FetchFlags(..), fetchCommand+         , FreezeFlags(..), freezeCommand+         , genBoundsCommand+         , OutdatedFlags(..), outdatedCommand+         , GetFlags(..), getCommand, unpackCommand+         , checkCommand+         , formatCommand+         , updateCommand+         , ListFlags(..), listCommand+         , InfoFlags(..), infoCommand+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , runCommand+         , InitFlags(initVerbosity), initCommand+         , SDistFlags(..), SDistExFlags(..), sdistCommand+         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand+         , ActAsSetupFlags(..), actAsSetupCommand+         , SandboxFlags(..), sandboxCommand+         , ExecFlags(..), execCommand+         , UserConfigFlags(..), userConfigCommand+         , reportCommand+         , manpageCommand+         )+import Distribution.Simple.Setup+         ( HaddockTarget(..)+         , DoctestFlags(..), doctestCommand+         , HaddockFlags(..), haddockCommand, defaultHaddockFlags+         , HscolourFlags(..), hscolourCommand+         , ReplFlags(..)+         , CopyFlags(..), copyCommand+         , RegisterFlags(..), registerCommand+         , CleanFlags(..), cleanCommand+         , TestFlags(..), BenchmarkFlags(..)+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag+         , configAbsolutePaths+         )++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)++import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Config+         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff+         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )+import Distribution.Client.Targets+         ( readUserTargets )+import qualified Distribution.Client.List as List+         ( list, info )++import qualified Distribution.Client.CmdConfigure as CmdConfigure+import qualified Distribution.Client.CmdBuild     as CmdBuild+import qualified Distribution.Client.CmdRepl      as CmdRepl+import qualified Distribution.Client.CmdFreeze    as CmdFreeze+import qualified Distribution.Client.CmdHaddock   as CmdHaddock+import qualified Distribution.Client.CmdRun       as CmdRun+import qualified Distribution.Client.CmdTest      as CmdTest+import qualified Distribution.Client.CmdBench     as CmdBench++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)+import Distribution.Client.Outdated           (outdated)+import Distribution.Client.Check as Check     (check)+--import Distribution.Client.Clean            (clean)+import qualified Distribution.Client.Upload as Upload+import Distribution.Client.Run                (run, splitRunArgs)+import Distribution.Client.SrcDist            (sdist)+import Distribution.Client.Get                (get)+import Distribution.Client.Reconfigure        (Check(..), reconfigure)+import Distribution.Client.Nix                (nixInstantiate+                                              ,nixShell+                                              ,nixShellIfSandboxed)+import Distribution.Client.Sandbox            (sandboxInit+                                              ,sandboxAddSource+                                              ,sandboxDelete+                                              ,sandboxDeleteSource+                                              ,sandboxListSources+                                              ,sandboxHcPkg+                                              ,dumpPackageEnvironment++                                              ,loadConfigOrSandboxConfig+                                              ,findSavedDistPref+                                              ,initPackageDBIfNeeded+                                              ,maybeWithSandboxDirOnSearchPath+                                              ,maybeWithSandboxPackageInfo+                                              ,tryGetIndexFilePath+                                              ,sandboxBuildDir+                                              ,updateSandboxConfigFileFlag+                                              ,updateInstallDirs++                                              ,getPersistOrConfigCompiler)+import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB)+import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)+import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)+import Distribution.Client.Tar                (createTarGzFile)+import Distribution.Client.Types              (Password (..))+import Distribution.Client.Init               (initCabal)+import Distribution.Client.Manpage            (manpage)+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import Distribution.Client.Utils              (determineNumJobs+#if defined(mingw32_HOST_OS)+                                              ,relaxEncodingErrors+#endif+                                              )++import Distribution.Package (packageId)+import Distribution.PackageDescription+         ( BuildType(..), Executable(..), buildable )+#ifdef CABAL_PARSEC+import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )+#else+import Distribution.PackageDescription.Parse ( readGenericPackageDescription )+#endif++import Distribution.PackageDescription.PrettyPrint+         ( writeGenericPackageDescription )+import qualified Distribution.Simple as Simple+import qualified Distribution.Make as Make+import qualified Distribution.Types.UnqualComponentName as Make+import Distribution.Simple.Build+         ( startInterpreter )+import Distribution.Simple.Command+         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)+         , CommandType(..), commandsRun, commandAddAction, hiddenCommand+         , commandFromSpec, commandShowOptions )+import Distribution.Simple.Compiler (Compiler(..), PackageDBStack)+import Distribution.Simple.Configure+         ( configCompilerAuxEx, ConfigStateFileError(..)+         , getPersistBuildConfig, interpretPackageDbFlags+         , tryGetPersistBuildConfig )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program (defaultProgramDb+                                   ,configureAllKnownPrograms+                                   ,simpleProgramInvocation+                                   ,getProgramInvocationOutput)+import Distribution.Simple.Program.Db (reconfigurePrograms)+import qualified Distribution.Simple.Setup as Cabal+import Distribution.Simple.Utils+         ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler+         , findPackageDesc, tryFindPackageDesc )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+         ( Verbosity, normal )+import Distribution.Version+         ( Version, mkVersion, orLaterVersion )+import qualified Paths_cabal_install (version)++import System.Environment       (getArgs, getProgName)+import System.Exit              (exitFailure, exitSuccess)+import System.FilePath          ( dropExtension, splitExtension+                                , takeExtension, (</>), (<.>))+import System.IO                ( BufferMode(LineBuffering), hSetBuffering+#ifdef mingw32_HOST_OS+                                , stderr+#endif+                                , stdout )+import System.Directory         (doesFileExist, getCurrentDirectory)+import Data.Monoid              (Any(..))+import Control.Exception        (SomeException(..), try)+import Control.Monad            (mapM_)++#ifdef MONOLITHIC+import qualified UnitTests+import qualified MemoryUsageTests+import qualified SolverQuickCheck+import qualified IntegrationTests2+import qualified System.Environment as Monolithic+#endif++-- | Entry point+--+main :: IO ()+#ifdef MONOLITHIC+main = do+    mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE"+    case mb_exec of+        Just "UnitTests"         -> UnitTests.main+        Just "MemoryUsageTests"  -> MemoryUsageTests.main+        Just "SolverQuickCheck"  -> SolverQuickCheck.main+        Just "IntegrationTests2" -> IntegrationTests2.main+        Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE"+        Nothing -> main'+#else+main = main'+#endif++main' :: IO ()+main' = do+  -- Enable line buffering so that we can get fast feedback even when piped.+  -- This is especially important for CI and build systems.+  hSetBuffering stdout LineBuffering+  -- The default locale encoding for Windows CLI is not UTF-8 and printing+  -- Unicode characters to it will fail unless we relax the handling of encoding+  -- errors when writing to stderr and stdout.+#ifdef mingw32_HOST_OS+  relaxEncodingErrors stdout+  relaxEncodingErrors stderr+#endif+  getArgs >>= mainWorker++mainWorker :: [String] -> IO ()+mainWorker args = topHandler $+  case commandsRun (globalCommand commands) commands args of+    CommandHelp   help                 -> printGlobalHelp help+    CommandList   opts                 -> printOptionsList opts+    CommandErrors errs                 -> printErrors errs+    CommandReadyToGo (globalFlags, commandParse)  ->+      case commandParse of+        _ | fromFlagOrDefault False (globalVersion globalFlags)+            -> printVersion+          | fromFlagOrDefault False (globalNumericVersion globalFlags)+            -> printNumericVersion+        CommandHelp     help           -> printCommandHelp help+        CommandList     opts           -> printOptionsList opts+        CommandErrors   errs           -> printErrors errs+        CommandReadyToGo action        -> do+          globalFlags' <- updateSandboxConfigFileFlag globalFlags+          action globalFlags'++  where+    printCommandHelp help = do+      pname <- getProgName+      putStr (help pname)+    printGlobalHelp help = do+      pname <- getProgName+      configFile <- defaultConfigFile+      putStr (help pname)+      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"+            ++ "  " ++ configFile ++ "\n"+      exists <- doesFileExist configFile+      when (not exists) $+          putStrLn $ "This file will be generated with sensible "+                  ++ "defaults if you run 'cabal update'."+    printOptionsList = putStr . unlines+    printErrors errs = dieNoVerbosity $ intercalate "\n" errs+    printNumericVersion = putStrLn $ display Paths_cabal_install.version+    printVersion        = putStrLn $ "cabal-install version "+                                  ++ display Paths_cabal_install.version+                                  ++ "\ncompiled using version "+                                  ++ display cabalVersion+                                  ++ " of the Cabal library "++    commands = map commandFromSpec commandSpecs+    commandSpecs =+      [ regularCmd installCommand installAction+      , regularCmd updateCommand updateAction+      , regularCmd listCommand listAction+      , regularCmd infoCommand infoAction+      , regularCmd fetchCommand fetchAction+      , regularCmd freezeCommand freezeAction+      , regularCmd getCommand getAction+      , hiddenCmd  unpackCommand unpackAction+      , regularCmd checkCommand checkAction+      , regularCmd sdistCommand sdistAction+      , regularCmd uploadCommand uploadAction+      , regularCmd reportCommand reportAction+      , regularCmd runCommand runAction+      , regularCmd initCommand initAction+      , regularCmd configureExCommand configureAction+      , regularCmd reconfigureCommand reconfigureAction+      , regularCmd buildCommand buildAction+      , regularCmd replCommand replAction+      , regularCmd sandboxCommand sandboxAction+      , regularCmd doctestCommand doctestAction+      , regularCmd haddockCommand haddockAction+      , regularCmd execCommand execAction+      , regularCmd userConfigCommand userConfigAction+      , regularCmd cleanCommand cleanAction+      , regularCmd genBoundsCommand genBoundsAction+      , regularCmd outdatedCommand outdatedAction+      , wrapperCmd copyCommand copyVerbosity copyDistPref+      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref+      , wrapperCmd registerCommand regVerbosity regDistPref+      , regularCmd testCommand testAction+      , regularCmd benchmarkCommand benchmarkAction+      , hiddenCmd  uninstallCommand uninstallAction+      , hiddenCmd  formatCommand formatAction+      , hiddenCmd  upgradeCommand upgradeAction+      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction+      , hiddenCmd  actAsSetupCommand actAsSetupAction+      , hiddenCmd  manpageCommand (manpageAction commandSpecs)++      , regularCmd  CmdConfigure.configureCommand CmdConfigure.configureAction+      , regularCmd  CmdBuild.buildCommand         CmdBuild.buildAction+      , regularCmd  CmdRepl.replCommand           CmdRepl.replAction+      , regularCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction+      , regularCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction+      , regularCmd  CmdRun.runCommand             CmdRun.runAction+      , regularCmd  CmdTest.testCommand           CmdTest.testAction+      , regularCmd  CmdBench.benchCommand         CmdBench.benchAction+      ]++type Action = GlobalFlags -> IO ()++regularCmd :: CommandUI flags -> (flags -> [String] -> action)+           -> CommandSpec action+regularCmd ui action =+  CommandSpec ui ((flip commandAddAction) action) NormalCommand++hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)+          -> CommandSpec action+hiddenCmd ui action =+  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))+  HiddenCommand++wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)+           -> (flags -> Flag String) -> CommandSpec Action+wrapperCmd ui verbosity distPref =+  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand++wrapperAction :: Monoid flags+              => CommandUI flags+              -> (flags -> Flag Verbosity)+              -> (flags -> Flag String)+              -> Command Action+wrapperAction command verbosityFlag distPrefFlag =+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do+    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)+    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+    let config = either (\(SomeException _) -> mempty) snd load+    distPref <- findSavedDistPref config (distPrefFlag flags)+    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }+    setupWrapper verbosity setupScriptOptions Nothing+                 command (const flags) extraArgs++configureAction :: (ConfigFlags, ConfigExFlags)+                -> [String] -> Action+configureAction (configFlags, configExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (configDistPref configFlags)+  nixInstantiate verbosity distPref True globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let configFlags'   = savedConfigureFlags   config `mappend` configFlags+        configExFlags' = savedConfigureExFlags config `mappend` configExFlags+        globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAuxEx configFlags'++    -- If we're working inside a sandbox and the user has set the -w option, we+    -- may need to create a sandbox-local package DB for this compiler and add a+    -- timestamp record for this compiler to the timestamp file.+    let configFlags''  = case useSandbox of+          NoSandbox               -> configFlags'+          (UseSandbox sandboxDir) -> setPackageDB sandboxDir+                                    comp platform configFlags'++    writeConfigFlags verbosity distPref (configFlags'', configExFlags')++    -- What package database(s) to use+    let packageDBs :: PackageDBStack+        packageDBs+          = interpretPackageDbFlags+            (fromFlag (configUserInstall configFlags''))+            (configPackageDBs configFlags'')++    whenUsingSandbox useSandbox $ \sandboxDir -> do+      initPackageDBIfNeeded verbosity configFlags'' comp progdb+      -- NOTE: We do not write the new sandbox package DB location to+      -- 'cabal.sandbox.config' here because 'configure -w' must not affect+      -- subsequent 'install' (for UI compatibility with non-sandboxed mode).++      indexFile     <- tryGetIndexFilePath verbosity config+      maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+        (compilerId comp) platform++    maybeWithSandboxDirOnSearchPath useSandbox $+      withRepoContext verbosity globalFlags' $ \repoContext ->+        configure verbosity packageDBs repoContext+                  comp platform progdb configFlags'' configExFlags' extraArgs++reconfigureAction :: (ConfigFlags, ConfigExFlags)+                  -> [String] -> Action+reconfigureAction flags@(configFlags, _) _ globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (configDistPref configFlags)+  let checkFlags = Check $ \_ saved -> do+        let flags' = saved <> flags+        unless (saved == flags') $ info verbosity message+        pure (Any True, flags')+        where+          -- This message is correct, but not very specific: it will list all+          -- of the new flags, even if some have not actually changed. The+          -- *minimal* set of changes is more difficult to determine.+          message =+            "flags changed: "+            ++ unwords (commandShowOptions configureExCommand flags)+  nixInstantiate verbosity distPref True globalFlags config+  _ <-+    reconfigure configureAction+    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    checkFlags [] globalFlags config+  pure ()++buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action+buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)+  -- Calls 'configureAction' to do the real work, so nothing special has to be+  -- done to support sandboxes.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags extraArgs+++-- | Actually do the work of building the package. This is separate from+-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke+-- 'reconfigure' twice.+build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()+build verbosity config distPref buildFlags extraArgs =+  setupWrapper verbosity setupOptions Nothing+               (Cabal.buildCommand progDb) mkBuildFlags extraArgs+  where+    progDb       = defaultProgramDb+    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }++    mkBuildFlags version = filterBuildFlags version config buildFlags'+    buildFlags' = buildFlags+      { buildVerbosity = toFlag verbosity+      , buildDistPref  = toFlag distPref+      }++-- | Make sure that we don't pass new flags to setup scripts compiled against+-- old versions of Cabal.+filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags+filterBuildFlags version config buildFlags+  | version >= mkVersion [1,19,1] = buildFlags_latest+  -- Cabal < 1.19.1 doesn't support 'build -j'.+  | otherwise                      = buildFlags_pre_1_19_1+  where+    buildFlags_pre_1_19_1 = buildFlags {+      buildNumJobs = NoFlag+      }+    buildFlags_latest     = buildFlags {+      -- Take the 'jobs' setting '~/.cabal/config' into account.+      buildNumJobs = Flag . Just . determineNumJobs $+                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)+      }+    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config+    numJobsCmdLineFlag = buildNumJobs buildFlags+++replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action+replAction (replFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (replDistPref replFlags)+  cwd     <- getCurrentDirectory+  pkgDesc <- findPackageDesc cwd+  let+    -- There is a .cabal file in the current directory: start a REPL and load+    -- the project's modules.+    onPkgDesc = do+      let noAddSource = case replReload replFlags of+            Flag True -> SkipAddSourceDepsCheck+            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck+                        (buildOnly buildExFlags)++      -- Calls 'configureAction' to do the real work, so nothing special has to+      -- be done to support sandboxes.+      _ <-+        reconfigure configureAction+        verbosity distPref useSandbox noAddSource NoFlag+        mempty [] globalFlags config+      let progDb = defaultProgramDb+          setupOptions = defaultSetupScriptOptions+            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]+            , useDistPref     = distPref+            }+          replFlags'   = replFlags+            { replVerbosity = toFlag verbosity+            , replDistPref  = toFlag distPref+            }++      nixShell verbosity distPref globalFlags config $ do+        maybeWithSandboxDirOnSearchPath useSandbox $+          setupWrapper verbosity setupOptions Nothing+          (Cabal.replCommand progDb) (const replFlags') extraArgs++    -- No .cabal file in the current directory: just start the REPL (possibly+    -- using the sandbox package DB).+    onNoPkgDesc = do+      let configFlags = savedConfigureFlags config+      (comp, platform, programDb) <- configCompilerAux' configFlags+      programDb' <- reconfigurePrograms verbosity+                                        (replProgramPaths replFlags)+                                        (replProgramArgs replFlags)+                                        programDb+      nixShell verbosity distPref globalFlags config $ do+        startInterpreter verbosity programDb' comp platform+                        (configPackageDB' configFlags)++  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc++installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> Action+installAction (configFlags, _, installFlags, _) _ globalFlags+  | fromFlagOrDefault False (installOnly installFlags) = do+      let verb = fromFlagOrDefault normal (configVerbosity configFlags)+      (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags+      dist <- findSavedDistPref config (configDistPref configFlags)+      let setupOpts = defaultSetupScriptOptions { useDistPref = dist }+      nixShellIfSandboxed verb dist globalFlags config useSandbox $+        setupWrapper+        verb setupOpts Nothing+        installCommand (const mempty) []++installAction+  (configFlags, configExFlags, installFlags, haddockFlags)+  extraArgs globalFlags = do+  let verb = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)+                          <$> loadConfigOrSandboxConfig verb globalFlags++  let sandboxDist =+        case useSandbox of+          NoSandbox             -> NoFlag+          UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir+  dist <- findSavedDistPref config+          (configDistPref configFlags `mappend` sandboxDist)++  nixShellIfSandboxed verb dist globalFlags config useSandbox $ do+    targets <- readUserTargets verb extraArgs++    -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to+    -- 'configure' when run inside a sandbox.  Right now, running+    --+    -- $ cabal sandbox init && cabal configure -w /path/to/ghc+    --   && cabal build && cabal install+    --+    -- performs the compilation twice unless you also pass -w to 'install'.+    -- However, this is the same behaviour that 'cabal install' has in the normal+    -- mode of operation, so we stick to it for consistency.++    let configFlags'    = maybeForceTests installFlags' $+                          savedConfigureFlags   config `mappend`+                          configFlags { configDistPref = toFlag dist }+        configExFlags'  = defaultConfigExFlags         `mappend`+                          savedConfigureExFlags config `mappend` configExFlags+        installFlags'   = defaultInstallFlags          `mappend`+                          savedInstallFlags     config `mappend` installFlags+        haddockFlags'   = defaultHaddockFlags          `mappend`+                          savedHaddockFlags     config `mappend`+                          haddockFlags { haddockDistPref = toFlag dist }+        globalFlags'    = savedGlobalFlags      config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags'+    -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the+    -- future.+    progdb' <- configureAllKnownPrograms verb progdb++    -- If we're working inside a sandbox and the user has set the -w option, we+    -- may need to create a sandbox-local package DB for this compiler and add a+    -- timestamp record for this compiler to the timestamp file.+    configFlags'' <- case useSandbox of+      NoSandbox               -> configAbsolutePaths $ configFlags'+      (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform+                                                      configFlags'++    whenUsingSandbox useSandbox $ \sandboxDir -> do+      initPackageDBIfNeeded verb configFlags'' comp progdb'++      indexFile     <- tryGetIndexFilePath verb config+      maybeAddCompilerTimestampRecord verb sandboxDir indexFile+        (compilerId comp) platform++    -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means+    -- that 'cabal install some-package' inside a sandbox will sometimes reinstall+    -- modified add-source deps, even if they are not among the dependencies of+    -- 'some-package'. This can also prevent packages that depend on older+    -- versions of add-source'd packages from building (see #1362).+    maybeWithSandboxPackageInfo verb configFlags'' globalFlags'+                                comp platform progdb useSandbox $ \mSandboxPkgInfo ->+                                maybeWithSandboxDirOnSearchPath useSandbox $+      withRepoContext verb globalFlags' $ \repoContext ->+        install verb+                (configPackageDB' configFlags'')+                repoContext+                comp platform progdb'+                useSandbox mSandboxPkgInfo+                globalFlags' configFlags'' configExFlags'+                installFlags' haddockFlags'+                targets++      where+        -- '--run-tests' implies '--enable-tests'.+        maybeForceTests installFlags' configFlags' =+          if fromFlagOrDefault False (installRunTests installFlags')+          then configFlags' { configTests = toFlag True }+          else configFlags'++testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags+           -> IO ()+testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (testDistPref testFlags)+  let noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags)+      buildFlags'    = buildFlags+                      { buildVerbosity = testVerbosity testFlags }+      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configTests configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable tests"+            let flags' = ( configFlags { configTests = toFlag True }+                        , configExFlags+                        )+            pure (Any True, flags')++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  _ <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+        testFlags'     = testFlags { testDistPref = toFlag distPref }++    -- The package was just configured, so the LBI must be available.+    names <- componentNamesFromLBI verbosity distPref "test suites"+              (\c -> case c of { LBI.CTest{} -> True; _ -> False })+    let extraArgs'+          | null extraArgs = case names of+            ComponentNamesUnknown -> []+            ComponentNames names' -> [ Make.unUnqualComponentName name+                                    | LBI.CTestName name <- names' ]+          | otherwise      = extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config distPref buildFlags' extraArgs'++    maybeWithSandboxDirOnSearchPath useSandbox $+      setupWrapper verbosity setupOptions Nothing+      Cabal.testCommand (const testFlags') extraArgs'++data ComponentNames = ComponentNamesUnknown+                    | ComponentNames [LBI.ComponentName]++-- | Return the names of all buildable components matching a given predicate.+componentNamesFromLBI :: Verbosity -> FilePath -> String+                         -> (LBI.Component -> Bool)+                         -> IO ComponentNames+componentNamesFromLBI verbosity distPref targetsDescr compPred = do+  eLBI <- tryGetPersistBuildConfig distPref+  case eLBI of+    Left err -> case err of+      -- Note: the build config could have been generated by a custom setup+      -- script built against a different Cabal version, so it's crucial that+      -- we ignore the bad version error here.+      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown+      _                               -> die' verbosity (show err)+    Right lbi -> do+      let pkgDescr = LBI.localPkgDescr lbi+          names    = map LBI.componentName+                     . filter (buildable . LBI.componentBuildInfo)+                     . filter compPred $+                     LBI.pkgComponents pkgDescr+      if null names+        then do notice verbosity $ "Package has no buildable "+                  ++ targetsDescr ++ "."+                exitSuccess -- See #3215.++        else return $! (ComponentNames names)++benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)+                   -> [String] -> GlobalFlags+                   -> IO ()+benchmarkAction+  (benchmarkFlags, buildFlags, buildExFlags)+  extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal+                       (benchmarkVerbosity benchmarkFlags)++  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)+  let buildFlags'    = buildFlags+                      { buildVerbosity = benchmarkVerbosity benchmarkFlags }+      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags)++  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->+        if fromFlagOrDefault False (configBenchmarks configFlags)+          then pure (mempty, flags)+          else do+            info verbosity "reconfiguring to enable benchmarks"+            let flags' = ( configFlags { configBenchmarks = toFlag True }+                        , configExFlags+                        )+            pure (Any True, flags')+++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags')+    checkFlags [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+        benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }++    -- The package was just configured, so the LBI must be available.+    names <- componentNamesFromLBI verbosity distPref "benchmarks"+            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })+    let extraArgs'+          | null extraArgs = case names of+            ComponentNamesUnknown -> []+            ComponentNames names' -> [ Make.unUnqualComponentName name+                                    | LBI.CBenchName name <- names']+          | otherwise      = extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags' extraArgs'++    maybeWithSandboxDirOnSearchPath useSandbox $+      setupWrapper verbosity setupOptions Nothing+      Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'++haddockAction :: HaddockFlags -> [String] -> Action+haddockAction haddockFlags extraArgs globalFlags = do+  let verbosity = fromFlag (haddockVerbosity haddockFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    let haddockFlags' = defaultHaddockFlags      `mappend`+                        savedHaddockFlags config' `mappend`+                        haddockFlags { haddockDistPref = toFlag distPref }+        setupScriptOptions = defaultSetupScriptOptions+                             { useDistPref = distPref }+    setupWrapper verbosity setupScriptOptions Nothing+      haddockCommand (const haddockFlags') extraArgs+    when (haddockForHackage haddockFlags == Flag ForHackage) $ do+      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+      let dest = distPref </> name <.> "tar.gz"+          name = display (packageId pkg) ++ "-docs"+          docDir = distPref </> "doc" </> "html"+      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) extraArgs++cleanAction :: CleanFlags -> [String] -> Action+cleanAction cleanFlags extraArgs globalFlags = do+  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+  let config = either (\(SomeException _) -> mempty) snd load+  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)+  let setupScriptOptions = defaultSetupScriptOptions+                           { useDistPref = distPref+                           , useWin32CleanHack = True+                           }+      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }+  setupWrapper verbosity setupScriptOptions Nothing+               cleanCommand (const cleanFlags') extraArgs+  where+    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)++listAction :: ListFlags -> [String] -> Action+listAction listFlags extraArgs globalFlags = do+  let verbosity = fromFlag (listVerbosity listFlags)+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` listPackageDBs listFlags+        }+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.list verbosity+       (configPackageDB' configFlags)+       repoContext+       comp+       progdb+       listFlags+       extraArgs++infoAction :: InfoFlags -> [String] -> Action+infoAction infoFlags extraArgs globalFlags = do+  let verbosity = fromFlag (infoVerbosity infoFlags)+  targets <- readUserTargets verbosity extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` infoPackageDBs infoFlags+        }+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAuxEx configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.info verbosity+       (configPackageDB' configFlags)+       repoContext+       comp+       progdb+       globalFlags'+       infoFlags+       targets++updateAction :: Flag Verbosity -> [String] -> Action+updateAction verbosityFlag extraArgs globalFlags = do+  let verbosity = fromFlag verbosityFlag+  unless (null extraArgs) $+    die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    update verbosity repoContext++upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> Action+upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $+    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."+ where+  verbosity = fromFlag (configVerbosity configFlags)++fetchAction :: FetchFlags -> [String] -> Action+fetchAction fetchFlags extraArgs globalFlags = do+  let verbosity = fromFlag (fetchVerbosity fetchFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    fetch verbosity+        (configPackageDB' configFlags)+        repoContext+        comp platform progdb globalFlags' fetchFlags+        targets++freezeAction :: FreezeFlags -> [String] -> Action+freezeAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config NoFlag+  nixShell verbosity distPref globalFlags config $ do+    let configFlags  = savedConfigureFlags config+        globalFlags' = savedGlobalFlags config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags++    maybeWithSandboxPackageInfo+      verbosity configFlags globalFlags'+      comp platform progdb useSandbox $ \mSandboxPkgInfo ->+        maybeWithSandboxDirOnSearchPath useSandbox $+        withRepoContext verbosity globalFlags' $ \repoContext ->+          freeze verbosity+            (configPackageDB' configFlags)+            repoContext+            comp platform progdb+            mSandboxPkgInfo+            globalFlags' freezeFlags++genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+genBoundsAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config NoFlag+  nixShell verbosity distPref globalFlags config $ do+    let configFlags  = savedConfigureFlags config+        globalFlags' = savedGlobalFlags config `mappend` globalFlags+    (comp, platform, progdb) <- configCompilerAux' configFlags++    maybeWithSandboxPackageInfo+      verbosity configFlags globalFlags'+      comp platform progdb useSandbox $ \mSandboxPkgInfo ->+        maybeWithSandboxDirOnSearchPath useSandbox $+        withRepoContext verbosity globalFlags' $ \repoContext ->+          genBounds verbosity+                (configPackageDB' configFlags)+                repoContext+                comp platform progdb+                mSandboxPkgInfo+                globalFlags' freezeFlags++outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()+outdatedAction outdatedFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (outdatedVerbosity outdatedFlags)+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, _progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    outdated verbosity outdatedFlags repoContext+             comp platform++uploadAction :: UploadFlags -> [String] -> Action+uploadAction uploadFlags extraArgs globalFlags = do+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+      tarfiles     = extraArgs+  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $+    die' verbosity "the 'upload' command expects at least one .tar.gz archive."+  checkTarFiles extraArgs+  maybe_password <-+    case uploadPasswordCmd uploadFlags'+    of Flag (xs:xss) -> Just . Password <$>+                        getProgramInvocationOutput verbosity+                        (simpleProgramInvocation xs xss)+       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'+  withRepoContext verbosity globalFlags' $ \repoContext -> do+    if fromFlag (uploadDoc uploadFlags')+    then do+      when (length tarfiles > 1) $+       die' verbosity $ "the 'upload' command can only upload documentation "+             ++ "for one package at a time."+      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles+      Upload.uploadDoc verbosity+                       repoContext+                       (flagToMaybe $ uploadUsername uploadFlags')+                       maybe_password+                       (fromFlag (uploadCandidate uploadFlags'))+                       tarfile+    else do+      Upload.upload verbosity+                    repoContext+                    (flagToMaybe $ uploadUsername uploadFlags')+                    maybe_password+                    (fromFlag (uploadCandidate uploadFlags'))+                    tarfiles+    where+    verbosity = fromFlag (uploadVerbosity uploadFlags)+    checkTarFiles tarfiles+      | not (null otherFiles)+      = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "+           ++ intercalate ", " otherFiles+      | otherwise = sequence_+                      [ do exists <- doesFileExist tarfile+                           unless exists $ die' verbosity $ "file not found: " ++ tarfile+                      | tarfile <- tarfiles ]++      where otherFiles = filter (not . isTarGzFile) tarfiles+            isTarGzFile file = case splitExtension file of+              (file', ".gz") -> takeExtension file' == ".tar"+              _              -> False+    generateDocTarball config = do+      notice verbosity $+        "No documentation tarball specified. "+        ++ "Building a documentation tarball with default settings...\n"+        ++ "If you need to customise Haddock options, "+        ++ "run 'haddock --for-hackage' first "+        ++ "to generate a documentation tarball."+      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })+                    [] globalFlags+      distPref <- findSavedDistPref config NoFlag+      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"++checkAction :: Flag Verbosity -> [String] -> Action+checkAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  unless (null extraArgs) $+    die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs+  allOk <- Check.check (fromFlag verbosityFlag)+  unless allOk exitFailure++formatAction :: Flag Verbosity -> [String] -> Action+formatAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  path <- case extraArgs of+    [] -> do cwd <- getCurrentDirectory+             tryFindPackageDesc cwd+    (p:_) -> return p+  pkgDesc <- readGenericPackageDescription verbosity path+  -- Uses 'writeFileAtomic' under the hood.+  writeGenericPackageDescription path pkgDesc++uninstallAction :: Flag Verbosity -> [String] -> Action+uninstallAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+      package = case extraArgs of+        p:_ -> p+        _   -> "PACKAGE_NAME"+  die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' "+    ++ "operation. "+    ++ "It will likely be implemented at some point in the future; "+    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "+    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."+++sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action+sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do+  let verbosity = fromFlag (sDistVerbosity sdistFlags)+  unless (null extraArgs) $+    die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs+  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)+  let config = either (\(SomeException _) -> mempty) snd load+  distPref <- findSavedDistPref config (sDistDistPref sdistFlags)+  let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }+  sdist sdistFlags' sdistExFlags++reportAction :: ReportFlags -> [String] -> Action+reportAction reportFlags extraArgs globalFlags = do+  let verbosity = fromFlag (reportVerbosity reportFlags)+  unless (null extraArgs) $+    die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+      reportFlags' = savedReportFlags config `mappend` reportFlags++  withRepoContext verbosity globalFlags' $ \repoContext ->+   Upload.report verbosity repoContext+    (flagToMaybe $ reportUsername reportFlags')+    (flagToMaybe $ reportPassword reportFlags')++runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action+runAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (buildDistPref buildFlags)+  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)+  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  config' <-+    reconfigure configureAction+    verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags)+    mempty [] globalFlags config+  nixShell verbosity distPref globalFlags config $ do+    lbi <- getPersistBuildConfig distPref+    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs++    maybeWithSandboxDirOnSearchPath useSandbox $+      build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]++    maybeWithSandboxDirOnSearchPath useSandbox $+      run verbosity lbi exe exeArgs++getAction :: GetFlags -> [String] -> Action+getAction getFlags extraArgs globalFlags = do+  let verbosity = fromFlag (getVerbosity getFlags)+  targets <- readUserTargets verbosity extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->+   get verbosity+    repoContext+    globalFlags'+    getFlags+    targets++unpackAction :: GetFlags -> [String] -> Action+unpackAction getFlags extraArgs globalFlags = do+  getAction getFlags extraArgs globalFlags++initAction :: InitFlags -> [String] -> Action+initAction initFlags extraArgs globalFlags = do+  let verbosity = fromFlag (initVerbosity initFlags)+  when (extraArgs /= []) $+    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })+  let configFlags  = savedConfigureFlags config+  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, _, progdb) <- configCompilerAux' configFlags+  withRepoContext verbosity globalFlags' $ \repoContext ->+    initCabal verbosity+            (configPackageDB' configFlags)+            repoContext+            comp+            progdb+            initFlags++sandboxAction :: SandboxFlags -> [String] -> Action+sandboxAction sandboxFlags extraArgs globalFlags = do+  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)+  case extraArgs of+    -- Basic sandbox commands.+    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags+    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags+    ("add-source":extra) -> do+        when (noExtraArgs extra) $+          die' verbosity "The 'sandbox add-source' command expects at least one argument"+        sandboxAddSource verbosity extra sandboxFlags globalFlags+    ("delete-source":extra) -> do+        when (noExtraArgs extra) $+          die' verbosity ("The 'sandbox delete-source' command expects " +++              "at least one argument")+        sandboxDeleteSource verbosity extra sandboxFlags globalFlags+    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags++    -- More advanced commands.+    ("hc-pkg":extra) -> do+        when (noExtraArgs extra) $+            die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument"+        sandboxHcPkg verbosity sandboxFlags globalFlags extra+    ["buildopts"] -> die' verbosity "Not implemented!"++    -- Hidden commands.+    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags++    -- Error handling.+    [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')"+    _  -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs++  where+    noExtraArgs = (<1) . length++execAction :: ExecFlags -> [String] -> Action+execAction execFlags extraArgs globalFlags = do+  let verbosity = fromFlag (execVerbosity execFlags)+  (useSandbox, 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 useSandbox comp platform progdb extraArgs++userConfigAction :: UserConfigFlags -> [String] -> Action+userConfigAction ucflags extraArgs globalFlags = do+  let verbosity = fromFlag (userConfigVerbosity ucflags)+      force     = fromFlag (userConfigForce ucflags)+  case extraArgs of+    ("init":_) -> do+      path       <- configFile+      fileExists <- doesFileExist path+      if (not fileExists || (fileExists && force))+      then void $ createDefaultConfigFile verbosity path+      else die' verbosity $ path ++ " already exists."+    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags+    ("update":_) -> userConfigUpdate verbosity globalFlags+    -- Error handling.+    [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"+    _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs+  where configFile = getConfigFilePath (globalConfigFile globalFlags)++-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+--+win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action+win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do+  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse+win32SelfUpgradeAction _ _ _ = return ()++-- | Used as an entry point when cabal-install needs to invoke itself+-- as a setup script. This can happen e.g. when doing parallel builds.+--+actAsSetupAction :: ActAsSetupFlags -> [String] -> Action+actAsSetupAction actAsSetupFlags args _globalFlags =+  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)+  in case bt of+    Simple    -> Simple.defaultMainArgs args+    Configure -> Simple.defaultMainWithHooksArgs+                  Simple.autoconfUserHooks args+    Make      -> Make.defaultMainArgs args+    Custom               -> error "actAsSetupAction Custom"+    (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"++manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action+manpageAction commands flagVerbosity extraArgs _ = do+  let verbosity = fromFlag flagVerbosity+  unless (null extraArgs) $+    die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs   pname <- getProgName   let cabalCmd = if takeExtension pname == ".exe"                  then dropExtension pname
Setup.hs view
@@ -11,7 +11,7 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)                                           , absoluteInstallDirs                                           )-import Distribution.Simple.Utils ( copyFiles+import Distribution.Simple.Utils ( installOrdinaryFiles                                  , notice ) import Distribution.Simple.Setup ( buildVerbosity                                  , copyDest@@ -27,6 +27,16 @@ import System.Process ( runProcess ) import System.FilePath ( (</>) ) +-- WARNING to editors of this file:+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- At this moment (Cabal 1.23), whatever you write here must be+-- compatible with ALL Cabal libraries which we support bootstrapping+-- with.  This is because pre-setup-depends versions of cabal-install will+-- build Setup.hs against the version of Cabal which MATCHES the library+-- that cabal-install was built against.  There is no way of overriding+-- this behavior without bumping the required 'cabal-version' in our+-- Cabal file.  Travis will let you know if we fail to install from+-- tarball!  main :: IO () main = defaultMainWithHooks $ simpleUserHooks@@ -50,4 +60,4 @@ installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () installManpage pkg lbi verbosity copy = do   let destDir = mandir (absoluteInstallDirs pkg lbi copy) </> "man1"-  copyFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]+  installOrdinaryFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]
bash-completion/cabal view
@@ -10,9 +10,10 @@ #   - executable|test-suite|benchmark for the three _cabal_list() {-	cat *.cabal |-	grep -Ei "^[[:space:]]*($1)[[:space:]]" |-	sed -e "s/.* \([^ ]*\).*/\1/"+    for f in ./*.cabal; do+        grep -Ei "^[[:space:]]*($1)[[:space:]]" "$f" |+        sed -e "s/.* \([^ ]*\).*/\1/"+    done }  # List possible targets depending on the command supplied as parameter.  The@@ -20,17 +21,17 @@ # This is a temporary workaround. _cabal_targets() {-	# If command ($*) contains build, repl, test or bench completes with-	# targets of according type.-	[ -f *.cabal ] || return 0-	local comp-	for comp in $*; do-		[ $comp == build ] && _cabal_list "executable|test-suite|benchmark" && break-		[ $comp == repl  ] && _cabal_list "executable|test-suite|benchmark" && break-		[ $comp == run   ] && _cabal_list "executable"                      && break-		[ $comp == test  ] && _cabal_list            "test-suite"           && break-		[ $comp == bench ] && _cabal_list                       "benchmark" && break-	done+    # If command ($*) contains build, repl, test or bench completes with+    # targets of according type.+    local comp+    for comp in "$@"; do+        [ "$comp" == new-build ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == build     ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == repl      ] && _cabal_list "executable|test-suite|benchmark" && break+        [ "$comp" == run       ] && _cabal_list "executable"                      && break+        [ "$comp" == test      ] && _cabal_list            "test-suite"           && break+        [ "$comp" == bench     ] && _cabal_list                       "benchmark" && break+    done }  # List possible subcommands of a cabal subcommand.@@ -87,7 +88,7 @@     cmd[${COMP_CWORD}]="--list-options"      # the resulting completions should be put into this array-    COMPREPLY=( $( compgen -W "$( ${cmd[@]} ) $( _cabal_targets ${cmd[@]} ) $( _cabal_subcommands ${COMP_WORDS[@]} )" -- $cur ) )+    COMPREPLY=( $( compgen -W "$( eval "${cmd[@]}" 2>/dev/null ) $( _cabal_targets "${cmd[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$cur" ) ) }  complete -F _cabal -o default cabal
bootstrap.sh view
@@ -16,7 +16,10 @@ #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS -die () { printf "\nError during cabal-install bootstrap:\n$1\n" >&2 && exit 2 ;}+die() {+    printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2+    exit 2+}  # programs, you can override these by setting environment vars GHC="${GHC:-ghc}"@@ -51,13 +54,12 @@ SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" -# Try to respect $TMPDIR.-[ -"$TMPDIR"- = -""- ] &&-  export TMPDIR=/tmp/cabal-$(echo $(od -XN4 -An /dev/random)) && mkdir $TMPDIR+TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX)+export TMPDIR  # Check for a C compiler, using user-set $CC, if any, first. for c in $CC gcc clang cc icc; do-  $c --version 2>&1 >/dev/null && CC=$c &&+  $c --version 1>/dev/null 2>&1 && CC=$c &&   echo "Using $c for C compiler. If this is not what you want, set CC." >&2 &&   break done@@ -67,9 +69,15 @@   If a C compiler is installed make sure it is on your PATH, or set $CC.'  # Find the correct linker/linker-wrapper.+#+# See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153. LINK="$(for link in collect2 ld; do-          [ $($CC -print-prog-name=$link) = $link ] && continue ||-          $CC -print-prog-name=$link+          if [ $($CC -print-prog-name=$link) = $link ]+          then+              continue+          else+              $CC -print-prog-name=$link && break+          fi         done)"  # Fall back to "ld"... might work.@@ -158,9 +166,9 @@   esac done -# Do not try to use -j with GHC older than 7.8+# Do not try to use -j with GHC 7.8 or older case $GHC_VER in-    7.4*|7.6*)+    7.4*|7.6*|7.8*)         JOBS=""         ;;     *)@@ -200,9 +208,9 @@  # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.9";    PARSEC_VER_REGEXP="[3]\.[01]\."+PARSEC_VER="3.1.11";    PARSEC_VER_REGEXP="[3]\.[01]\."                        # >= 3.0 && < 3.2-DEEPSEQ_VER="1.4.2.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."+DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."                        # >= 1.1 && < 2  case "$GHC_VER" in@@ -213,35 +221,35 @@         ;;     *)         # GHC >= 7.8-        BINARY_VER="0.8.3.0"+        BINARY_VER="0.8.5.1"         BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9         ;; esac  -TEXT_VER="1.2.2.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"+TEXT_VER="1.2.2.2";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"                        # >= 0.2 && < 1.3-NETWORK_VER="2.6.3.1"; NETWORK_VER_REGEXP="2\.[0-6]\."+NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\."                        # >= 2.0 && < 2.7 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\."                        # >= 2.6 && < 2.7-CABAL_VER="1.24.2.0";  CABAL_VER_REGEXP="1\.24\.[2-9]"-                       # >= 1.24.2 && < 1.25-TRANS_VER="0.5.2.0";   TRANS_VER_REGEXP="0\.[45]\."+CABAL_VER="2.0.0.2";  CABAL_VER_REGEXP="2\.0\.[0-9]"+                       # >= 2.0 && < 2.1+TRANS_VER="0.5.4.0";   TRANS_VER_REGEXP="0\.[45]\."                        # >= 0.2.* && < 0.6 MTL_VER="2.2.1";       MTL_VER_REGEXP="[2]\."                        #  >= 2.0 && < 3-HTTP_VER="4000.3.3";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"+HTTP_VER="4000.3.7";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"                        # >= 4000.2.5 < 4000.4 ZLIB_VER="0.6.1.2";    ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"                        # >= 0.5.3 && <= 0.7-TIME_VER="1.7"         TIME_VER_REGEXP="1\.[1-7]\.?"-                       # >= 1.1 && < 1.8+TIME_VER="1.8.0.2"     TIME_VER_REGEXP="1\.[1-8]\.?"+                       # >= 1.1 && < 1.9 RANDOM_VER="1.1"       RANDOM_VER_REGEXP="1\.[01]\.?"                        # >= 1 && < 1.2 STM_VER="2.4.4.1";     STM_VER_REGEXP="2\."                        # == 2.*-ASYNC_VER="2.1.0";     ASYNC_VER_REGEXP="2\."+ASYNC_VER="2.1.1.1";   ASYNC_VER_REGEXP="2\."                        # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?"                        # >=1.0.0.0 && <1.2@@ -249,10 +257,16 @@                        # >=1.0.0.0 && <1.1 BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1"                        # 0.1.*-BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_REGEXP="1\."+BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\."                        # >=1.0 CRYPTOHASH_SHA256_VER="0.11.100.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"                        # 0.11.*+MINTTY_VER="0.1";      MINTTY_VER_REGEXP="0\.1\.?"+                       # 0.1.*+ECHO_VER="0.1.3";      ECHO_VER_REGEXP="0\.1\.[3-9]"+                       # >= 0.1.3 && < 0.2+EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?"+                       # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"                        # 0.0.* HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])"@@ -260,7 +274,7 @@ BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?" TAR_VER="0.5.0.3";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?"                        # >= 0.5.0.3  && < 0.6-HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\."+HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\."                        # 1.*  HACKAGE_URL="https://hackage.haskell.org/package"@@ -354,7 +368,7 @@   [ -x Setup ] && ./Setup clean   [ -f Setup ] && rm Setup -  ${GHC} --make ${JOBS} Setup -o Setup ||+  ${GHC} --make ${JOBS} Setup -o Setup -XRank2Types -XFlexibleContexts ||     die "Compiling the Setup script failed."    [ -x Setup ] || die "The Setup script does not exist or cannot be run"@@ -399,10 +413,8 @@         echo "Downloading ${PKG}-${VER}..."         fetch_pkg ${PKG} ${VER}     fi-    unpack_pkg ${PKG} ${VER}-    cd "${PKG}-${VER}"-    install_pkg ${PKG} ${VER}-    cd ..+    unpack_pkg "${PKG}" "${VER}"+    (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER})   fi } @@ -414,9 +426,7 @@         if need_pkg "Cabal" ${CABAL_VER_REGEXP}         then             echo "Cabal-${CABAL_VER} will be installed from the local Git clone."-            cd ../Cabal-            install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP}-            cd ../cabal-install+            (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP})         else             echo "Cabal is already installed and the version is ok."         fi@@ -481,6 +491,9 @@     ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \     ${CRYPTOHASH_SHA256_VER_REGEXP}+info_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP}+info_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP}+info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP} info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP} info_pkg "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP}@@ -516,6 +529,9 @@     ${BASE64_BYTESTRING_VER_REGEXP} do_pkg   "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \     ${CRYPTOHASH_SHA256_VER_REGEXP}+do_pkg "mintty"        ${MINTTY_VER}        ${MINTTY_VER_REGEXP}+do_pkg "echo"          ${ECHO_VER}          ${ECHO_VER_REGEXP}+do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}  # We conditionally install bytestring-builder, depending on the bytestring
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            1.24.0.2+Version:            2.0.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -9,17 +9,9 @@ bug-reports:        https://github.com/haskell/cabal/issues License:            BSD3 License-File:       LICENSE-Author:             Lemmih <lemmih@gmail.com>-                    Paolo Martini <paolo@nemail.it>-                    Bjorn Bringert <bjorn@bringert.net>-                    Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    Duncan Coutts <duncan@community.haskell.org>-Maintainer:         cabal-devel@haskell.org-Copyright:          2005 Lemmih <lemmih@gmail.com>-                    2006 Paolo Martini <paolo@nemail.it>-                    2007 Bjorn Bringert <bjorn@bringert.net>-                    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    2007-2012 Duncan Coutts <duncan@community.haskell.org>+Author:             Cabal Development Team (see AUTHORS file)+Maintainer:         Cabal Development Team <cabal-devel@haskell.org>+Copyright:          2003-2017, Cabal Development Team Category:           Distribution Build-type:         Custom Cabal-Version:      >= 1.10@@ -30,98 +22,67 @@   -- Generated with '../Cabal/misc/gen-extra-source-files.sh'   -- Do NOT edit this section manually; instead, run the script.   -- BEGIN gen-extra-source-files-  tests/IntegrationTests/custom-setup/common.sh-  tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal-  tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs-  tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal-  tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs-  tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs-  tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal-  tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs-  tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal-  tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs-  tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal-  tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh-  tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh-  tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh-  tests/IntegrationTests/custom/common.sh-  tests/IntegrationTests/custom/should_run/plain.err-  tests/IntegrationTests/custom/should_run/plain.sh-  tests/IntegrationTests/custom/should_run/plain/A.hs-  tests/IntegrationTests/custom/should_run/plain/Setup.hs-  tests/IntegrationTests/custom/should_run/plain/plain.cabal-  tests/IntegrationTests/exec/common.sh-  tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err-  tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh-  tests/IntegrationTests/exec/should_run/Foo.hs-  tests/IntegrationTests/exec/should_run/My.hs-  tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out-  tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh-  tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out-  tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh-  tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out-  tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh-  tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh-  tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh-  tests/IntegrationTests/exec/should_run/my.cabal-  tests/IntegrationTests/exec/should_run/runs_given_command.out-  tests/IntegrationTests/exec/should_run/runs_given_command.sh-  tests/IntegrationTests/freeze/common.sh-  tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh-  tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh-  tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh-  tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh-  tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh-  tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh-  tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh-  tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh-  tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh-  tests/IntegrationTests/freeze/should_run/my.cabal-  tests/IntegrationTests/freeze/should_run/runs_without_error.sh-  tests/IntegrationTests/manpage/common.sh-  tests/IntegrationTests/manpage/should_run/outputs_manpage.sh-  tests/IntegrationTests/multiple-source/common.sh-  tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh-  tests/IntegrationTests/multiple-source/should_run/p/Setup.hs-  tests/IntegrationTests/multiple-source/should_run/p/p.cabal-  tests/IntegrationTests/multiple-source/should_run/q/Setup.hs-  tests/IntegrationTests/multiple-source/should_run/q/q.cabal-  tests/IntegrationTests/new-build/monitor_cabal_files.sh-  tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs-  tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs-  tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal-  tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs-  tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs-  tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in-  tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in-  tests/IntegrationTests/regression/common.sh-  tests/IntegrationTests/regression/t3199.sh-  tests/IntegrationTests/regression/t3199/Main.hs-  tests/IntegrationTests/regression/t3199/Setup.hs-  tests/IntegrationTests/regression/t3199/test-3199.cabal-  tests/IntegrationTests/sandbox-sources/common.sh-  tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err-  tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh-  tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs-  tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal-  tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs-  tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal-  tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs-  tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal-  tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs-  tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal-  tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh-  tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out-  tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh-  tests/IntegrationTests/user-config/common.sh-  tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err-  tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh-  tests/IntegrationTests/user-config/should_run/overwrites_with_f.out-  tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh-  tests/IntegrationTests/user-config/should_run/runs_without_error.out-  tests/IntegrationTests/user-config/should_run/runs_without_error.sh-  tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out-  tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh+  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/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/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/cabal.project+  tests/IntegrationTests2/targets/simple/p.cabal+  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  source-repository head@@ -141,55 +102,65 @@   description:  Get Network.URI from the network-uri package   default:      True +Flag debug-expensive-assertions+  description:  Enable expensive assertions for testing or debugging+  default:      False+  manual:       True++Flag debug-conflict-sets+  description:  Add additional information to ConflictSets+  default:      False+  manual:       True++Flag debug-tracetree+  description:  Compile in support for tracetree (used to debug the solver)+  default:      False+  manual:       True++flag parsec+  description:  Use parsec parser. This requires 'Cabal' library built with its parsec flag enabled.+  default:      False+  manual:       True++-- When we do CI, we build our binaries on one machine, and then+-- ship them to another machine for testing.  Because we use+-- static linking (since it makes this sort of redeploy MUCH+-- easier), if we build five executables, that means we+-- need to ship ALL the Haskell libraries five times.  That's+-- a waste of space!  A better strategy is to statically link+-- everything into a single binary.  That's what this flag does.+flag monolithic+  description:  Build cabal-install also with all of its test and support code.  Used by our continuous integration.+  default:      False+  manual:       True+ executable cabal     main-is:        Main.hs-    ghc-options:    -Wall -fwarn-tabs+    ghc-options:    -Wall -fwarn-tabs -rtsopts     if impl(ghc >= 8.0)         ghc-options: -Wcompat                      -Wnoncanonical-monad-instances                      -Wnoncanonical-monadfail-instances      other-modules:-        Distribution.Client.BuildTarget         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage         Distribution.Client.BuildReports.Types         Distribution.Client.BuildReports.Upload         Distribution.Client.Check+        Distribution.Client.CmdBench         Distribution.Client.CmdBuild         Distribution.Client.CmdConfigure+        Distribution.Client.CmdFreeze+        Distribution.Client.CmdHaddock         Distribution.Client.CmdRepl-        Distribution.Client.ComponentDeps+        Distribution.Client.CmdRun+        Distribution.Client.CmdTest+        Distribution.Client.CmdErrorMessages         Distribution.Client.Config         Distribution.Client.Configure         Distribution.Client.Dependency-        Distribution.Client.Dependency.TopDown-        Distribution.Client.Dependency.TopDown.Constraints-        Distribution.Client.Dependency.TopDown.Types         Distribution.Client.Dependency.Types-        Distribution.Client.Dependency.Modular-        Distribution.Client.Dependency.Modular.Assignment-        Distribution.Client.Dependency.Modular.Builder-        Distribution.Client.Dependency.Modular.Configured-        Distribution.Client.Dependency.Modular.ConfiguredConversion-        Distribution.Client.Dependency.Modular.ConflictSet-        Distribution.Client.Dependency.Modular.Cycles-        Distribution.Client.Dependency.Modular.Dependency-        Distribution.Client.Dependency.Modular.Explore-        Distribution.Client.Dependency.Modular.Flag-        Distribution.Client.Dependency.Modular.Index-        Distribution.Client.Dependency.Modular.IndexConversion-        Distribution.Client.Dependency.Modular.Linking-        Distribution.Client.Dependency.Modular.Log-        Distribution.Client.Dependency.Modular.Message-        Distribution.Client.Dependency.Modular.Package-        Distribution.Client.Dependency.Modular.Preference-        Distribution.Client.Dependency.Modular.PSQ-        Distribution.Client.Dependency.Modular.Solver-        Distribution.Client.Dependency.Modular.Tree-        Distribution.Client.Dependency.Modular.Validate-        Distribution.Client.Dependency.Modular.Var-        Distribution.Client.Dependency.Modular.Version         Distribution.Client.DistDirLayout         Distribution.Client.Exec         Distribution.Client.Fetch@@ -204,6 +175,7 @@         Distribution.Client.Haddock         Distribution.Client.HttpUtils         Distribution.Client.IndexUtils+        Distribution.Client.IndexUtils.Timestamp         Distribution.Client.Init         Distribution.Client.Init.Heuristics         Distribution.Client.Init.Licenses@@ -214,13 +186,13 @@         Distribution.Client.JobControl         Distribution.Client.List         Distribution.Client.Manpage+        Distribution.Client.Nix+        Distribution.Client.Outdated         Distribution.Client.PackageHash-        Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils-        Distribution.Client.PkgConfigDb-        Distribution.Client.PlanIndex         Distribution.Client.ProjectBuilding+        Distribution.Client.ProjectBuilding.Types         Distribution.Client.ProjectConfig         Distribution.Client.ProjectConfig.Types         Distribution.Client.ProjectConfig.Legacy@@ -228,32 +200,87 @@         Distribution.Client.ProjectPlanning         Distribution.Client.ProjectPlanning.Types         Distribution.Client.ProjectPlanOutput-        Distribution.Client.Run         Distribution.Client.RebuildMonad+        Distribution.Client.Reconfigure+        Distribution.Client.Run         Distribution.Client.Sandbox         Distribution.Client.Sandbox.Index         Distribution.Client.Sandbox.PackageEnvironment         Distribution.Client.Sandbox.Timestamp         Distribution.Client.Sandbox.Types+        Distribution.Client.SavedFlags+        Distribution.Client.Security.DNS         Distribution.Client.Security.HTTP         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist+        Distribution.Client.SolverInstallPlan+        Distribution.Client.SourceFiles+        Distribution.Client.Store         Distribution.Client.Tar         Distribution.Client.Targets+        Distribution.Client.TargetSelector         Distribution.Client.Types         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils-        Distribution.Client.Utils.LabeledGraph+        Distribution.Client.Utils.Assertion         Distribution.Client.Utils.Json         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade         Distribution.Client.Compat.ExecutablePath+        Distribution.Client.Compat.FileLock         Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Prelude         Distribution.Client.Compat.Process         Distribution.Client.Compat.Semaphore-        Distribution.Client.Compat.Time+        Distribution.Solver.Types.ComponentDeps+        Distribution.Solver.Types.ConstraintSource+        Distribution.Solver.Types.DependencyResolver+        Distribution.Solver.Types.Flag+        Distribution.Solver.Types.InstalledPreference+        Distribution.Solver.Types.InstSolverPackage+        Distribution.Solver.Types.LabeledPackageConstraint+        Distribution.Solver.Types.OptionalStanza+        Distribution.Solver.Types.PackageConstraint+        Distribution.Solver.Types.PackageFixedDeps+        Distribution.Solver.Types.PackageIndex+        Distribution.Solver.Types.PackagePath+        Distribution.Solver.Types.PackagePreferences+        Distribution.Solver.Types.PkgConfigDb+        Distribution.Solver.Types.Progress+        Distribution.Solver.Types.ResolverPackage+        Distribution.Solver.Types.Settings+        Distribution.Solver.Types.SolverId+        Distribution.Solver.Types.SolverPackage+        Distribution.Solver.Types.SourcePackage+        Distribution.Solver.Types.Variable+        Distribution.Solver.Modular+        Distribution.Solver.Modular.Assignment+        Distribution.Solver.Modular.Builder+        Distribution.Solver.Modular.Configured+        Distribution.Solver.Modular.ConfiguredConversion+        Distribution.Solver.Modular.ConflictSet+        Distribution.Solver.Modular.Cycles+        Distribution.Solver.Modular.Dependency+        Distribution.Solver.Modular.Explore+        Distribution.Solver.Modular.Flag+        Distribution.Solver.Modular.Index+        Distribution.Solver.Modular.IndexConversion+        Distribution.Solver.Modular.Linking+        Distribution.Solver.Modular.LabeledGraph+        Distribution.Solver.Modular.Log+        Distribution.Solver.Modular.Message+        Distribution.Solver.Modular.Package+        Distribution.Solver.Modular.Preference+        Distribution.Solver.Modular.PSQ+        Distribution.Solver.Modular.RetryLog+        Distribution.Solver.Modular.Solver+        Distribution.Solver.Modular.Tree+        Distribution.Solver.Modular.Validate+        Distribution.Solver.Modular.Var+        Distribution.Solver.Modular.Version+        Distribution.Solver.Modular.WeightedPSQ         Paths_cabal_install      -- NOTE: when updating build-depends, don't forget to update version regexps@@ -265,9 +292,12 @@         base16-bytestring >= 0.1.1 && < 0.2,         binary     >= 0.5      && < 0.9,         bytestring >= 0.9      && < 1,-        Cabal      >= 1.24.2 && < 1.25,+        Cabal      >= 2.0      && < 2.1,         containers >= 0.4      && < 0.6,         cryptohash-sha256 >= 0.11 && < 0.12,+        deepseq    >= 1.3      && < 1.5,+        echo       >= 0.1.3    && < 0.2,+        edit-distance >= 0.2.2 && < 0.3,         filepath   >= 1.3      && < 1.5,         hashable   >= 1.0      && < 2,         HTTP       >= 4000.1.5 && < 4000.4,@@ -276,7 +306,7 @@         random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,         tar        >= 0.5.0.3  && < 0.6,-        time       >= 1.4      && < 1.8,+        time       >= 1.4      && < 1.9,         zlib       >= 0.5.3    && < 0.7,         hackage-security >= 0.5.2.2 && < 0.6 @@ -290,7 +320,7 @@                      process   >= 1.0.1.1  && < 1.1.0.2     else       build-depends: directory >= 1.2 && < 1.4,-                     process   >= 1.1.0.2  && < 1.5+                     process   >= 1.1.0.2  && < 1.7      -- NOTE: you MUST include the network dependency even when network-uri     -- is pulled in, otherwise the constraint solver doesn't have enough@@ -309,13 +339,83 @@     else       build-depends: unix >= 2.5 && < 2.8 -    if arch(arm) && impl(ghc < 7.6)-       -- older ghc on arm does not support -threaded-       cc-options:  -DCABAL_NO_THREADED-    else-       ghc-options: -threaded+    if !(arch(arm) && impl(ghc < 7.6))+      ghc-options: -threaded -    c-sources: cbits/getnumcores.c+    -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a+    if os(aix)+      extra-libraries: bsd++    if flag(debug-expensive-assertions)+      cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS++    if flag(debug-conflict-sets)+      cpp-options: -DDEBUG_CONFLICT_SETS+      build-depends: base >= 4.8++    if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2++    if flag(parsec)+      cpp-options: -DCABAL_PARSEC++    hs-source-dirs: .+    if flag(monolithic)+      hs-source-dirs: tests+      other-modules:+        UnitTests+        UnitTests.Distribution.Client.ArbitraryInstances+        UnitTests.Distribution.Client.FileMonitor+        UnitTests.Distribution.Client.GZipUtils+        UnitTests.Distribution.Client.Glob+        UnitTests.Distribution.Client.IndexUtils.Timestamp+        UnitTests.Distribution.Client.InstallPlan+        UnitTests.Distribution.Client.JobControl+        UnitTests.Distribution.Client.ProjectConfig+        UnitTests.Distribution.Client.Sandbox+        UnitTests.Distribution.Client.Sandbox.Timestamp+        UnitTests.Distribution.Client.Store+        UnitTests.Distribution.Client.Tar+        UnitTests.Distribution.Client.Targets+        UnitTests.Distribution.Client.UserConfig+        UnitTests.Distribution.Solver.Modular.DSL+        UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils+        UnitTests.Distribution.Solver.Modular.MemoryUsage+        UnitTests.Distribution.Solver.Modular.PSQ+        UnitTests.Distribution.Solver.Modular.QuickCheck+        UnitTests.Distribution.Solver.Modular.RetryLog+        UnitTests.Distribution.Solver.Modular.Solver+        UnitTests.Distribution.Solver.Modular.WeightedPSQ+        UnitTests.Options+        MemoryUsageTests+        SolverQuickCheck+        IntegrationTests2+      cpp-options: -DMONOLITHIC+      build-depends:+        Cabal      >= 2.0 && < 2.1,+        QuickCheck >= 2.8.2,+        array,+        async,+        bytestring,+        containers,+        deepseq,+        directory,+        edit-distance,+        filepath,+        mtl,+        network,+        network-uri,+        pretty-show,+        random,+        tagged,+        tar,+        tasty,+        tasty-hunit,+        tasty-quickcheck,+        time,+        zlib+     default-language: Haskell2010  -- Small, fast running tests.@@ -323,29 +423,39 @@   type: exitcode-stdio-1.0   main-is: UnitTests.hs   hs-source-dirs: tests, .-  ghc-options: -Wall -fwarn-tabs+  ghc-options: -Wall -fwarn-tabs -main-is UnitTests   other-modules:+    Distribution.Client.Compat.FileLock     UnitTests.Distribution.Client.ArbitraryInstances-    UnitTests.Distribution.Client.Targets-    UnitTests.Distribution.Client.Compat.Time-    UnitTests.Distribution.Client.Dependency.Modular.PSQ-    UnitTests.Distribution.Client.Dependency.Modular.Solver-    UnitTests.Distribution.Client.Dependency.Modular.DSL     UnitTests.Distribution.Client.FileMonitor-    UnitTests.Distribution.Client.Glob     UnitTests.Distribution.Client.GZipUtils+    UnitTests.Distribution.Client.Glob+    UnitTests.Distribution.Client.IndexUtils.Timestamp+    UnitTests.Distribution.Client.InstallPlan+    UnitTests.Distribution.Client.JobControl+    UnitTests.Distribution.Client.ProjectConfig     UnitTests.Distribution.Client.Sandbox     UnitTests.Distribution.Client.Sandbox.Timestamp+    UnitTests.Distribution.Client.Store     UnitTests.Distribution.Client.Tar+    UnitTests.Distribution.Client.Targets     UnitTests.Distribution.Client.UserConfig-    UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils+    UnitTests.Distribution.Solver.Modular.PSQ+    UnitTests.Distribution.Solver.Modular.RetryLog+    UnitTests.Distribution.Solver.Modular.Solver+    UnitTests.Distribution.Solver.Modular.WeightedPSQ     UnitTests.Options+   build-depends:         base,+        async,         array,         bytestring,         Cabal,         containers,+        deepseq,         mtl,         pretty,         process,@@ -382,37 +492,224 @@   else     build-depends: unix -  if arch(arm)-    cc-options:  -DCABAL_NO_THREADED+  ghc-options: -fno-ignore-asserts++  if !(arch(arm) && impl(ghc < 7.6))+    ghc-options: -threaded++  if flag(debug-expensive-assertions)+    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS++  if flag(debug-conflict-sets)+    cpp-options: -DDEBUG_CONFLICT_SETS+    build-depends: base >= 4.8++  if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2++  default-language: Haskell2010++-- Tests to run with a limited stack and heap size+Test-Suite memory-usage-tests+  type: exitcode-stdio-1.0+  main-is: MemoryUsageTests.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests+  other-modules:+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils+    UnitTests.Distribution.Solver.Modular.MemoryUsage+    UnitTests.Options+  build-depends:+        base,+        async,+        array,+        bytestring,+        Cabal,+        containers,+        deepseq,+        mtl,+        pretty,+        process,+        directory,+        filepath,+        hashable,+        stm,+        tar,+        time,+        HTTP,+        zlib,+        binary,+        random,+        hackage-security,+        tagged,+        tasty,+        tasty-hunit++  if flag(old-directory)+    build-depends: old-time++  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6   else+    build-depends: network-uri < 2.6, network < 2.6++  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3++  if os(windows)+    build-depends: Win32+  else+    build-depends: unix++  ghc-options: -fno-ignore-asserts++  if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded++  if flag(debug-expensive-assertions)+    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS++  if flag(debug-conflict-sets)+    cpp-options: -DDEBUG_CONFLICT_SETS+    build-depends: base >= 4.8++  if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2+   default-language: Haskell2010 -test-suite integration-tests+-- Slow solver tests+Test-Suite solver-quickcheck   type: exitcode-stdio-1.0-  hs-source-dirs: tests-  main-is: IntegrationTests.hs+  main-is: SolverQuickCheck.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is SolverQuickCheck+  other-modules:+    UnitTests.Distribution.Solver.Modular.DSL+    UnitTests.Distribution.Solver.Modular.QuickCheck   build-depends:-    Cabal,-    async,-    base,-    bytestring,-    directory,-    filepath,-    process,-    regex-posix,-    tasty,-    tasty-hunit+        base,+        async,+        array,+        bytestring,+        Cabal,+        containers,+        deepseq >= 1.2,+        mtl,+        pretty,+        process,+        directory,+        filepath,+        hashable,+        stm,+        tar,+        time,+        HTTP,+        zlib,+        binary,+        random,+        hackage-security,+        tasty,+        tasty-quickcheck,+        QuickCheck >= 2.8.2,+        pretty-show +  if flag(old-directory)+    build-depends: old-time++  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6+  else+    build-depends: network-uri < 2.6, network < 2.6++  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3+   if os(windows)-    build-depends: Win32 >= 2 && < 3+    build-depends: Win32   else-    build-depends: unix >= 2.5 && < 2.8+    build-depends: unix +  if !(arch(arm) && impl(ghc < 7.6))+    ghc-options: -threaded++  if flag(debug-expensive-assertions)+    cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS++  if flag(debug-conflict-sets)+    cpp-options: -DDEBUG_CONFLICT_SETS+    build-depends: base >= 4.8++  if flag(debug-tracetree)+      cpp-options: -DDEBUG_TRACETREE+      build-depends: tracetree >= 0.1 && < 0.2++  default-language: Haskell2010++-- Integration tests that use the cabal-install code directly+-- but still build whole projects+test-suite integration-tests2+  type: exitcode-stdio-1.0+  main-is: IntegrationTests2.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is IntegrationTests2+  other-modules: Distribution.Client.Compat.FileLock+  build-depends:+        async,+        array,+        base,+        base16-bytestring,+        binary,+        bytestring,+        Cabal,+        containers,+        cryptohash-sha256,+        deepseq,+        directory,+        edit-distance,+        filepath,+        hackage-security,+        hashable,+        HTTP,+        mtl,+        network,+        network-uri,+        pretty,+        process,+        random,+        stm,+        tar,+        time,+        zlib,+        tasty,+        tasty-hunit,+        tagged++  if flag(old-bytestring)+    build-depends: bytestring-builder++  if flag(old-directory)+    build-depends: old-time++  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3++  if os(windows)+    build-depends: Win32+  else+    build-depends: unix+   if arch(arm)     cc-options:  -DCABAL_NO_THREADED   else     ghc-options: -threaded--  ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts   default-language: Haskell2010++custom-setup+  setup-depends: Cabal >= 2.0,+                 base,+                 process   >= 1.1.0.1  && < 1.7,+                 filepath   >= 1.3      && < 1.5
− cbits/getnumcores.c 
@@ -1,46 +0,0 @@-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612) && !defined(CABAL_NO_THREADED)-/* Since version 6.12, GHC's threaded RTS includes a getNumberOfProcessors-   function, so we try to use that if available. cabal-install is always built-   with -threaded nowadays.  */-#define HAS_GET_NUMBER_OF_PROCESSORS-#endif---#ifndef HAS_GET_NUMBER_OF_PROCESSORS--#if defined(_WIN32) && !defined(__CYGWIN__)-#include <windows.h>-#elif MACOS-#include <sys/param.h>-#include <sys/sysctl.h>-#elif __linux__-#include <unistd.h>-#endif--int getNumberOfProcessors() {-#if defined(_WIN32) && !defined(__CYGWIN__)-    SYSTEM_INFO sysinfo;-    GetSystemInfo(&sysinfo);-    return sysinfo.dwNumberOfProcessors;-#elif MACOS-    int nm[2];-    size_t len = 4;-    uint32_t count;--    nm[0] = CTL_HW; nm[1] = HW_AVAILCPU;-    sysctl(nm, 2, &count, &len, NULL, 0);--    if(count < 1) {-        nm[1] = HW_NCPU;-        sysctl(nm, 2, &count, &len, NULL, 0);-        if(count < 1) { count = 1; }-    }-    return count;-#elif __linux__-    return sysconf(_SC_NPROCESSORS_ONLN);-#else-    return 1;-#endif-}--#endif /* HAS_GET_NUMBER_OF_PROCESSORS */
changelog view
@@ -1,28 +1,53 @@ -*-change-log-*--1.24.0.2 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> December 2016-	* Adapted to the revert of a PVP-noncompliant API change in-	Cabal 1.24.2.0 (#4123).-	* Bumped the directory upper bound to < 1.4 (#4158). -1.24.0.1 Ryan Thomas <ryan@ryant.org> October 2016-	* Fixed issue with passing '--enable-profiling' when invoking-	Setup scripts built with older versions of Cabal (#3873).+2.0.0.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> August 2017+	* Removed the '--root-cmd' parameter of the 'install' command+	(#3356).+	* Deprecated 'cabal install --global' (#3356).+	* Changed 'cabal upload' to upload a package candidate by default+	(#3419). Same applies to uploading documentation.+	* Added a new 'cabal upload' flag '--publish' for publishing a+	package on Hackage instead of uploading a candidate (#3419).+	* Added optional solver output visualisation support via the+	tracetree package. Mainly intended for debugging (#3410).+	* Removed the '--check' option from 'cabal upload'+	(#1823). It was replaced by package candidates. 	* Fixed various behaviour differences between network transports 	(#3429).-	* Updated to depend on the latest hackage-security that fixes-	various issues on Windows.-	* Fixed 'new-build' to exit with a non-zero exit code on failure-	(#3506).-	* Store secure repo index data as 01-index.* (#3862).-	* Added new hackage-security root keys for distribution with-	cabal-install.-	* Fix an issue where 'cabal install' sometimes had to be run twice-	for packages with build-type: Custom and a custom-setup stanza-	(#3723).-	* 'cabal sdist' no longer ignores '--builddir' when the package's-	build-type is Custom (#3794).+	* The bootstrap script now works correctly when run from a Git+	clone (#3439).+	* Removed the top-down solver (#3598).+	* The '-v/--verbosity' option no longer affects GHC verbosity+	(except in the case of '-v0'). Use '--ghc-options=-v' to enable+	verbose GHC output (#3540, #3671).+	* Changed the default logfile template from+	'.../$pkgid.log' to '.../$compiler/$libname.log' (#3807).+	* Added a new command, 'cabal reconfigure', which re-runs 'configure'+	with the most recently used flags (#2214).+	* Added add the '--index-state' flag for requesting a specific+	version of the package index (#3893, #4115).+	* Support for building Backpack packages.  See+	https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst+	for more details.+	* Support the Nix package manager (#3651).+	* Made the 'template-haskell' package non-upgradable again (#4185).+	* Fixed password echoing on MinTTY (#4128).+	* Added a new solver flag, '--install-base-libraries', that allows+	any package to be installed or upgraded (#4209).+	* New 'cabal-install' command: 'outdated', for listing outdated+	version bounds in a .cabal file or a freeze file (#4207).+	* Added qualified constraints for setup dependencies. For example,+	--constraint="setup.bar == 1.0" constrains all setup dependencies on+	bar, and --constraint="foo:setup.bar == 1.0" constrains foo's setup+	dependency on bar (part of #3502).+	* Non-qualified constraints, such as --constraint="bar == 1.0", now+	only apply to top-level dependencies. They don't constrain setup or+	build-tool dependencies. The new syntax --constraint="any.bar == 1.0"+	constrains all uses of bar.+	* Added a technical preview version of the 'cabal doctest' command+	(#4480). -1.24.0.0 Ryan Thomas <ryan@ryant.org> May 2016+1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016 	* If there are multiple remote repos, 'cabal update' now updates 	them in parallel (#2503). 	* New 'cabal upload' option '-P'/'--password-command' for reading@@ -187,7 +212,7 @@ 	* HTTP-4000 package required, should fix bugs with http proxies 	* Now works with authenticated proxies. 	* On Windows can now override the proxy setting using an env var-	* Fix compatability with config files generated by older versions+	* Fix compatibility with config files generated by older versions 	* Warn if the hackage package list is very old 	* More helpful --help output, mention config file and examples 	* Better documentation in ~/.cabal/config file@@ -244,7 +269,7 @@  0.4 Duncan Coutts <duncan@haskell.org> Oct 2007 	* Renamed executable from 'cabal-install' to 'cabal'-	* Partial Windows compatability+	* Partial Windows compatibility 	* Do per-user installs by default 	* cabal install now installs the package in the current directory 	* Allow multiple remote servers
− tests/IntegrationTests.hs 
@@ -1,310 +0,0 @@-{-# LANGUAGE CPP #-}--- | Groups black-box tests of cabal-install and configures them to test--- the correct binary.------ This file should do nothing but import tests from other modules and run--- them with the path to the correct cabal-install binary.-module Main-       where---- Modules from Cabal.-import Distribution.Compat.CreatePipe (createPipe)-import Distribution.Compat.Environment (setEnv)-import Distribution.Compat.Internal.TempFile (createTempDirectory)-import Distribution.Simple.Configure (findDistPrefOrDefault)-import Distribution.Simple.Program.Builtin (ghcPkgProgram)-import Distribution.Simple.Program.Db-        (defaultProgramDb, requireProgram, setProgramSearchPath)-import Distribution.Simple.Program.Find-        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)-import Distribution.Simple.Program.Types-        ( Program(..), simpleProgram, programPath)-import Distribution.Simple.Setup ( Flag(..) )-import Distribution.Simple.Utils ( findProgramVersion, copyDirectoryRecursive )-import Distribution.Verbosity (normal)---- Third party modules.-import Control.Concurrent.Async (withAsync, wait)-import Control.Exception (bracket)-import Data.Maybe (fromMaybe)-import System.Directory-        ( canonicalizePath-        , findExecutable-        , getDirectoryContents-        , getTemporaryDirectory-        , doesDirectoryExist-        , removeDirectoryRecursive-        , doesFileExist )-import System.FilePath-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit (testCase, Assertion, assertFailure)-import Control.Monad ( filterM, forM, unless, when )-import Data.List (isPrefixOf, isSuffixOf, sort)-import Data.IORef (newIORef, writeIORef, readIORef)-import System.Exit (ExitCode(..))-import System.IO (withBinaryFile, IOMode(ReadMode))-import System.Process (runProcess, waitForProcess)-import Text.Regex.Posix ((=~))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as C8-import           Data.ByteString (ByteString)--#if MIN_VERSION_base(4,6,0)-import System.Environment ( getExecutablePath )-#endif---- | Test case.-data TestCase = TestCase-    { tcName :: String -- ^ Name of the shell script-    , tcBaseDirectory :: FilePath-    , tcCategory :: String-    , tcShouldX :: String-    , tcStdOutPath :: Maybe FilePath -- ^ File path of "golden standard output"-    , tcStdErrPath :: Maybe FilePath -- ^ File path of "golden standard error"-    }---- | Test result.-data TestResult = TestResult-    { trExitCode :: ExitCode-    , trStdOut :: ByteString-    , trStdErr :: ByteString-    , trWorkingDirectory :: FilePath-    }---- | Cabal executable-cabalProgram :: Program-cabalProgram = (simpleProgram "cabal") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }---- | Convert test result to string.-testResultToString :: TestResult -> String-testResultToString testResult =-    exitStatus ++ "\n" ++ workingDirectory ++ "\n\n" ++ stdOut ++ "\n\n" ++ stdErr-  where-    exitStatus = "Exit status: " ++ show (trExitCode testResult)-    workingDirectory = "Working directory: " ++ (trWorkingDirectory testResult)-    stdOut = "<stdout> was:\n" ++ C8.unpack (trStdOut testResult)-    stdErr = "<stderr> was:\n" ++ C8.unpack (trStdErr testResult)---- | Returns the command that was issued, the return code, and the output text-run :: FilePath -> String -> [String] -> IO TestResult-run cwd path args = do-  -- path is relative to the current directory; canonicalizePath makes it-  -- absolute, so that runProcess will find it even when changing directory.-  path' <- canonicalizePath path--  (pid, hReadStdOut, hReadStdErr) <- do-    -- Create pipes for StdOut and StdErr-    (hReadStdOut, hWriteStdOut) <- createPipe-    (hReadStdErr, hWriteStdErr) <- createPipe-    -- Run the process-    pid <- runProcess path' args (Just cwd) Nothing Nothing (Just hWriteStdOut) (Just hWriteStdErr)-    -- Return the pid and read ends of the pipes-    return (pid, hReadStdOut, hReadStdErr)-  -- Read subprocess output using asynchronous threads; we need to-  -- do this aynchronously to avoid deadlocks due to buffers filling-  -- up.-  withAsync (B.hGetContents hReadStdOut) $ \stdOutAsync -> do-    withAsync (B.hGetContents hReadStdErr) $ \stdErrAsync -> do-      -- Wait for the subprocess to terminate-      exitcode <- waitForProcess pid-      -- We can now be sure that no further output is going to arrive,-      -- so we wait for the results of the asynchronous reads.-      stdOut <- wait stdOutAsync-      stdErr <- wait stdErrAsync-      -- Done-      return $ TestResult exitcode stdOut stdErr cwd---- | Get a list of all names in a directory, excluding all hidden or--- system files/directories such as '.', '..'  or any files/directories--- starting with a '.'.-listDirectory :: FilePath -> IO [String]-listDirectory directory = do-  fmap (filter notHidden) $ getDirectoryContents directory-  where-    notHidden = not . isHidden-    isHidden name = "." `isPrefixOf` name---- | List a directory as per 'listDirectory', but return an empty list--- in case the directory does not exist.-listDirectoryLax :: FilePath -> IO [String]-listDirectoryLax directory = do-  d <- doesDirectoryExist directory-  if d then-    listDirectory directory-  else-    return [ ]--pathIfExists :: FilePath -> IO (Maybe FilePath)-pathIfExists p = do-  e <- doesFileExist p-  if e then-    return $ Just p-    else-      return Nothing--fileMatchesString :: FilePath -> ByteString -> IO Bool-fileMatchesString p s = do-  withBinaryFile p ReadMode $ \h -> do-    expected <- (C8.lines . normalizeLinebreaks) `fmap` B.hGetContents h -- Strict-    let actual = C8.lines $ normalizeLinebreaks s-    return $ length expected == length actual &&-             and (zipWith matches expected actual)-  where-    matches :: ByteString -> ByteString -> Bool-    matches pattern line-        | C8.pack "RE:" `B.isPrefixOf` pattern = line =~ C8.drop 3 pattern-        | otherwise                            = line == pattern--    -- This is a bit of a hack, but since we're comparing-    -- *text* output, we should be OK.-    normalizeLinebreaks = B.filter (not . ((==) 13))--mustMatch :: TestResult -> String -> ByteString -> Maybe FilePath -> Assertion-mustMatch _          _          _      Nothing         =  return ()-mustMatch testResult handleName actual (Just expected) = do-  m <- fileMatchesString expected actual-  unless m $ assertFailure $-      "<" ++ handleName ++ "> did not match file '"-      ++ expected ++ "'.\n" ++ testResultToString testResult--discoverTestCategories :: FilePath -> IO [String]-discoverTestCategories directory = do-  names <- listDirectory directory-  fmap sort $ filterM (\name -> doesDirectoryExist $ directory </> name) names--discoverTestCases :: FilePath -> String -> String -> IO [TestCase]-discoverTestCases baseDirectory category shouldX = do-  -- Find the names of the shell scripts-  names <- fmap (filter isTestCase) $ listDirectoryLax directory-  -- Fill in TestCase for each script-  forM (sort names) $ \name -> do-    stdOutPath <- pathIfExists $ directory </> name `replaceExtension` ".out"-    stdErrPath <- pathIfExists $ directory </> name `replaceExtension` ".err"-    return $ TestCase { tcName = name-                      , tcBaseDirectory = baseDirectory-                      , tcCategory = category-                      , tcShouldX = shouldX-                      , tcStdOutPath = stdOutPath-                      , tcStdErrPath = stdErrPath-                      }-  where-    directory = baseDirectory </> category </> shouldX-    isTestCase name = ".sh" `isSuffixOf` name--createTestCases :: [TestCase] -> (TestCase -> Assertion) -> IO [TestTree]-createTestCases testCases mk =-  return $ (flip map) testCases $ \tc -> testCase (tcName tc ++ suffix tc) $ mk tc-  where-    suffix tc = case (tcStdOutPath tc, tcStdErrPath tc) of-      (Nothing, Nothing) -> " (ignoring stdout+stderr)"-      (Just _ , Nothing) -> " (ignoring stderr)"-      (Nothing, Just _ ) -> " (ignoring stdout)"-      (Just _ , Just _ ) -> ""--runTestCase :: (TestResult -> Assertion) -> TestCase -> IO ()-runTestCase assertResult tc = do-  doRemove <- newIORef False-  bracket createWorkDirectory (removeWorkDirectory doRemove) $ \workDirectory -> do-    -- Run-    let scriptDirectory = workDirectory </> tcShouldX tc-    sh <- fmap (fromMaybe $ error "Cannot find 'sh' executable") $ findExecutable "sh"-    testResult <- run scriptDirectory sh [ "-e", tcName tc]-    -- Assert that we got what we expected-    assertResult testResult-    mustMatch testResult "stdout" (trStdOut testResult) (tcStdOutPath tc)-    mustMatch testResult "stderr" (trStdErr testResult) (tcStdErrPath tc)-    -- Only remove working directory if test succeeded-    writeIORef doRemove True-  where-    createWorkDirectory = do-      -- Create the temporary directory-      tempDirectory <- getTemporaryDirectory-      workDirectory <- createTempDirectory tempDirectory "cabal-install-test"-      -- Copy all the files from the category into the working directory.-      copyDirectoryRecursive normal-        (tcBaseDirectory tc </> tcCategory tc)-        workDirectory-      -- Done-      return workDirectory-    removeWorkDirectory doRemove workDirectory = do-        remove <- readIORef doRemove-        when remove $ removeDirectoryRecursive workDirectory--makeShouldXTests :: FilePath -> String -> String -> (TestResult -> Assertion) -> IO [TestTree]-makeShouldXTests baseDirectory category shouldX assertResult = do-  testCases <- discoverTestCases baseDirectory category shouldX-  createTestCases testCases $ \tc ->-      runTestCase assertResult tc--makeShouldRunTests :: FilePath -> String -> IO [TestTree]-makeShouldRunTests baseDirectory category = do-  makeShouldXTests baseDirectory category "should_run" $ \testResult -> do-    case trExitCode testResult of-      ExitSuccess ->-        return () -- We're good-      ExitFailure _ ->-        assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult--makeShouldFailTests :: FilePath -> String -> IO [TestTree]-makeShouldFailTests baseDirectory category = do-  makeShouldXTests baseDirectory category "should_fail" $ \testResult -> do-    case trExitCode testResult of-      ExitSuccess ->-        assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult-      ExitFailure _ ->-        return () -- We're good--discoverCategoryTests :: FilePath -> String -> IO [TestTree]-discoverCategoryTests baseDirectory category = do-  srTests <- makeShouldRunTests baseDirectory category-  sfTests <- makeShouldFailTests baseDirectory category-  return [ testGroup "should_run" srTests-         , testGroup "should_fail" sfTests-         ]--main :: IO ()-main = do-  -- Find executables and build directories, etc.-  distPref <- guessDistDir-  buildDir <- canonicalizePath (distPref </> "build/cabal")-  let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath-  (cabal, _) <- requireProgram normal cabalProgram (setProgramSearchPath programSearchPath defaultProgramDb)-  (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb-  baseDirectory <- canonicalizePath $ "tests" </> "IntegrationTests"-  -- Set up environment variables for test scripts-  setEnv "GHC_PKG" $ programPath ghcPkg-  setEnv "CABAL" $ programPath cabal-  -- Define default arguments-  setEnv "CABAL_ARGS" $ "--config-file=config-file"-  setEnv "CABAL_ARGS_NO_CONFIG_FILE" " "-  -- Discover all the test caregories-  categories <- discoverTestCategories baseDirectory-  -- Discover tests in each category-  tests <- forM categories $ \category -> do-    categoryTests <- discoverCategoryTests baseDirectory category-    return (category, categoryTests)-  -- Map into a test tree-  let testTree = map (\(category, categoryTests) -> testGroup category categoryTests) tests-  -- Run the tests-  defaultMain $ testGroup "Integration Tests" $ testTree---- See this function in Cabal's PackageTests. If you update this,--- update its copy in cabal-install.  (Why a copy here? I wanted--- to try moving this into the Cabal library, but to do this properly--- I'd have to BC'ify getExecutablePath, and then it got hairy, so--- I aborted and did something simple.)-guessDistDir :: IO FilePath-guessDistDir = do-#if MIN_VERSION_base(4,6,0)-    exe_path <- canonicalizePath =<< getExecutablePath-    let dist0 = dropFileName exe_path </> ".." </> ".."-    b <- doesFileExist (dist0 </> "setup-config")-#else-    let dist0 = error "no path"-        b = False-#endif-    -- Method (2)-    if b then canonicalizePath dist0-         else findDistPrefOrDefault NoFlag >>= canonicalizePath
− tests/IntegrationTests/custom-setup/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal 
@@ -1,8 +0,0 @@-name: Cabal-version: 99998-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base-  exposed-modules: CabalMessage
− tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs 
@@ -1,3 +0,0 @@-module CabalMessage where--message = "This is Cabal-99998"
− tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal 
@@ -1,8 +0,0 @@-name: Cabal-version: 99999-build-type: Simple-cabal-version: >= 1.2--library-  build-depends: base-  exposed-modules: CabalMessage
− tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs 
@@ -1,3 +0,0 @@-module CabalMessage where--message = "This is Cabal-99999"
− tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
− tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal 
@@ -1,9 +0,0 @@-name: custom-setup-without-cabal-defaultMain-version: 1.0-build-type: Custom-cabal-version: >= 1.2--custom-setup-  setup-depends: base--library
− tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs 
@@ -1,4 +0,0 @@-import System.Exit-import System.IO--main = hPutStrLn stderr "My custom Setup" >> exitFailure
− tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal 
@@ -1,9 +0,0 @@-name: custom-setup-without-cabal-version: 1.0-build-type: Custom-cabal-version: >= 99999--custom-setup-  setup-depends: base--library
− tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs 
@@ -1,5 +0,0 @@-import CabalMessage (message)-import System.Exit-import System.IO--main = hPutStrLn stderr message >> exitFailure
− tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal 
@@ -1,9 +0,0 @@-name: custom-setup-version: 1.0-build-type: Custom-cabal-version: >= 99999--custom-setup-  setup-depends: base, Cabal >= 99999--library
− tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh 
@@ -1,12 +0,0 @@-. ../common.sh-cd custom-setup-without-cabal-defaultMain--# This package has explicit setup dependencies that do not include Cabal.-# Compilation should fail because Setup.hs imports Distribution.Simple.-! cabal new-build custom-setup-without-cabal-defaultMain > output 2>&1-cat output-grep -q "\(Could not find module\|Failed to load interface for\).*Distribution\\.Simple" output \-    || die "Should not have been able to import Cabal"--grep -q "It is a member of the hidden package .*Cabal-" output \-    || die "Cabal should be available"
− tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh 
@@ -1,11 +0,0 @@-. ../common.sh-cd custom-setup-without-cabal--# This package has explicit setup dependencies that do not include Cabal.-# new-build should try to build it, even though the cabal-version cannot be-# satisfied by an installed version of Cabal (cabal-version: >= 99999). However,-# configure should fail because Setup.hs just prints an error message and exits.-! cabal new-build custom-setup-without-cabal > output 2>&1-cat output-grep -q "My custom Setup" output \-    || die "Expected output from custom Setup"
− tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh 
@@ -1,15 +0,0 @@-# Regression test for issue #3436--. ../common.sh-cabal sandbox init-cabal install ./Cabal-99998-cabal sandbox add-source Cabal-99999--# Install custom-setup, which has a setup dependency on Cabal-99999.-# cabal should build the setup script with Cabal-99999, but then-# configure should fail because Setup just prints an error message-# imported from Cabal and exits.-! cabal install custom-setup/ > output 2>&1--cat output-grep -q "This is Cabal-99999" output || die "Expected output from Cabal-99999"
− tests/IntegrationTests/custom/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/custom/should_run/plain.err 
@@ -1,2 +0,0 @@-Custom-Custom
− tests/IntegrationTests/custom/should_run/plain.sh 
@@ -1,4 +0,0 @@-. ../common.sh-cd plain-cabal configure-cabal build
− tests/IntegrationTests/custom/should_run/plain/A.hs 
@@ -1,1 +0,0 @@-module A where
− tests/IntegrationTests/custom/should_run/plain/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-import System.IO-main = hPutStrLn stderr "Custom" >> defaultMain
− tests/IntegrationTests/custom/should_run/plain/plain.cabal 
@@ -1,12 +0,0 @@-name:                plain-version:             0.1.0.0-license:             BSD3-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Custom-cabal-version:       >=1.10--library-  exposed-modules:     A-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/exec/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err 
@@ -1,1 +0,0 @@-RE:^cabal(\.exe)?: Please specify an executable to run$
− tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh 
@@ -1,3 +0,0 @@-. ../common.sh--cabal exec
− tests/IntegrationTests/exec/should_run/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--foo :: String-foo = "foo"
− tests/IntegrationTests/exec/should_run/My.hs 
@@ -1,5 +0,0 @@-module Main where--main :: IO ()-main = do-    putStrLn "This is my-executable"
− tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out 
@@ -1,1 +0,0 @@-This is my-executable
− tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh 
@@ -1,10 +0,0 @@-. ../common.sh--cabal sandbox delete > /dev/null-cabal exec my-executable && die "Unexpectedly found executable"--cabal sandbox init > /dev/null-cabal install > /dev/null--# Execute indirectly via bash to ensure that we go through $PATH-cabal exec sh -- -c my-executable || die "Did not find executable"
− tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out 
@@ -1,4 +0,0 @@-Config file path source is commandline option.-Config file config-file not found.-Writing default configuration to config-file-find_me_in_output
− tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh 
@@ -1,2 +0,0 @@-. ../common.sh-cabal exec echo find_me_in_output
− tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out 
@@ -1,1 +0,0 @@-This is my-executable
− tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh 
@@ -1,9 +0,0 @@-. ../common.sh--cabal sandbox delete > /dev/null-cabal exec my-executable && die "Unexpectedly found executable"--cabal sandbox init > /dev/null-cabal install > /dev/null--cabal exec my-executable || die "Did not find executable"
− tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh 
@@ -1,14 +0,0 @@-. ../common.sh--cabal sandbox delete > /dev/null-cabal exec my-executable && die "Unexpectedly found executable"--cabal sandbox init > /dev/null-cabal install > /dev/null--# The library should not be available outside the sandbox-"$GHC_PKG" list | grep -v "my-0.1"--# When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command-# should find the library.-cabal exec sh -- -c 'cd subdir && "$CABAL" sandbox hc-pkg list' | grep "my-0.1"
− tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh 
@@ -1,13 +0,0 @@-. ../common.sh--cabal sandbox delete > /dev/null-cabal exec my-executable && die "Unexpectedly found executable"--cabal sandbox init > /dev/null-cabal install > /dev/null--# The library should not be available outside the sandbox-"$GHC_PKG" list | grep -v "my-0.1"--# Execute ghc-pkg inside the sandbox; it should find my-0.1-cabal exec ghc-pkg list | grep "my-0.1"
− tests/IntegrationTests/exec/should_run/my.cabal 
@@ -1,14 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.2-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base---executable my-executable-    main-is:            My.hs-    build-depends:      base
− tests/IntegrationTests/exec/should_run/runs_given_command.out 
@@ -1,1 +0,0 @@-this string
− tests/IntegrationTests/exec/should_run/runs_given_command.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal configure > /dev/null-cabal exec echo this string
− tests/IntegrationTests/freeze/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze --disable-benchmarks-grep -v " criterion ==" cabal.config || die "should NOT have frozen criterion"
− tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze --disable-tests-grep -v " test-framework ==" cabal.config || die "should NOT have frozen test-framework"
− tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh 
@@ -1,5 +0,0 @@-. ../common.sh-# TODO: Test this against a package installed in the sandbox but not-# depended upon.-cabal freeze-grep -v "exceptions ==" cabal.config || die "should not have frozen exceptions"
− tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze-grep -v " my ==" cabal.config || die "should not have frozen self"
− tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze --dry-run-[ ! -e cabal.config ] || die "cabal.config file should not have been created"
− tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh 
@@ -1,4 +0,0 @@-. ../common.sh-# TODO: solver should find solution without extra flags too-cabal freeze --enable-benchmarks --reorder-goals --max-backjumps=-1-grep " criterion ==" cabal.config || die "should have frozen criterion"
− tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze --enable-tests-grep " test-framework ==" cabal.config || die "should have frozen test-framework"
− tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze-grep " base ==" cabal.config || die "'base' should have been frozen"
− tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh 
@@ -1,3 +0,0 @@-. ../common.sh-cabal freeze-grep " ghc-prim ==" cabal.config || die "'ghc-prim' should have been frozen"
− tests/IntegrationTests/freeze/should_run/my.cabal 
@@ -1,21 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.20.0-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base--test-suite test-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: tests-    main-is:    test-Foo.hs-    build-depends: base, my, test-framework--benchmark bench-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: benchmarks-    main-is:    benchmark-Foo.hs-    build-depends: base, my, criterion
− tests/IntegrationTests/freeze/should_run/runs_without_error.sh 
@@ -1,2 +0,0 @@-. ../common.sh-cabal freeze
− tests/IntegrationTests/manpage/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/manpage/should_run/outputs_manpage.sh 
@@ -1,11 +0,0 @@-. ../common.sh--OUTPUT=`cabal manpage`--# contains visible command descriptions-echo $OUTPUT | grep -q '\.B cabal install' || die "visible command description line not found in:\n----$OUTPUT\n----"--# does not contain hidden command descriptions-echo $OUTPUT | grep -q '\.B cabal manpage' && die "hidden command description line found in:\n----$OUTPUT\n----"--exit 0
− tests/IntegrationTests/multiple-source/common.sh 
@@ -1,8 +0,0 @@-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh 
@@ -1,11 +0,0 @@-. ../common.sh--# Create the sandbox-cabal sandbox init--# Add the sources-cabal sandbox add-source p-cabal sandbox add-source q--# Install the second package-cabal install q
− tests/IntegrationTests/multiple-source/should_run/p/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/multiple-source/should_run/p/p.cabal 
@@ -1,11 +0,0 @@-name:                p-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/multiple-source/should_run/q/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/multiple-source/should_run/q/q.cabal 
@@ -1,11 +0,0 @@-name:                q-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/new-build/monitor_cabal_files.sh 
@@ -1,8 +0,0 @@-. ./common.sh-cd monitor_cabal_files-cp q/q-broken.cabal.in q/q.cabal-echo "Run 1" | awk '{print;print > "/dev/stderr"}'-! cabal new-build q-cp q/q-fixed.cabal.in q/q.cabal-echo "Run 2" | awk '{print;print > "/dev/stderr"}'-cabal new-build q
− tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs 
@@ -1,1 +0,0 @@-module P where
− tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal 
@@ -1,12 +0,0 @@-name:                p-version:             1.0-license:             BSD3-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  exposed-modules:     P-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs 
@@ -1,4 +0,0 @@-module Main where-import P-main :: IO ()-main = return ()
− tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in 
@@ -1,12 +0,0 @@-name:                q-version:             0.1.0.0-license:             BSD3-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--executable q-  main-is:             Main.hs-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in 
@@ -1,12 +0,0 @@-name:                q-version:             0.1.0.0-license:             BSD3-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--executable q-  main-is:             Main.hs-  build-depends:       base, p-  default-language:    Haskell2010
− tests/IntegrationTests/regression/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/regression/t3199.sh 
@@ -1,12 +0,0 @@-. ./common.sh--if [[ `ghc --numeric-version` =~ "7\\." ]]; then-    cd t3199-    tmpfile=$(mktemp /tmp/cabal-t3199.XXXXXX)-    cabal sandbox init-    cabal sandbox add-source ../../../../../Cabal-    cabal install --package-db=clear --package-db=global --only-dep --dry-run > $tmpfile-    grep -q "the following would be installed" $tmpfile || die "Should've installed Cabal"-    grep -q Cabal $tmpfile || die "Should've installed Cabal"-    rm $tmpfile-fi
− tests/IntegrationTests/regression/t3199/Main.hs 
@@ -1,4 +0,0 @@-module Main where--main :: IO ()-main = putStrLn "Hello, Haskell!"
− tests/IntegrationTests/regression/t3199/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/regression/t3199/test-3199.cabal 
@@ -1,27 +0,0 @@-name:                test-t3199-version:             0.1.0.0-license:             BSD3-author:              Mikhail Glushenkov-maintainer:          mikhail.glushenkov@gmail.com-category:            Test-build-type:          Custom-cabal-version:       >=1.10--flag exe_2-     description: Build second exe-     default:     False--executable test-3199-1-  main-is:             Main.hs-  build-depends:       base-  default-language:    Haskell2010--executable test-3199-2-  main-is:             Main.hs-  build-depends:       base, ansi-terminal-  default-language:    Haskell2010--  if flag(exe_2)-     buildable: True-  else-     buildable: False
− tests/IntegrationTests/sandbox-sources/common.sh 
@@ -1,8 +0,0 @@-cabal() {-    "$CABAL" $CABAL_ARGS "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err 
@@ -1,3 +0,0 @@-Warning: Sources not registered: "q"--RE:^cabal(\.exe)?: The sources with the above errors were skipped\. \("q"\)$
− tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh 
@@ -1,10 +0,0 @@-. ../common.sh--# Create the sandbox-cabal sandbox init > /dev/null--# Add one source-cabal sandbox add-source p > /dev/null--# Remove a source that exists on disk, but is not registered-cabal sandbox delete-source q
− tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal 
@@ -1,11 +0,0 @@-name:                p-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal 
@@ -1,11 +0,0 @@-name:                q-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal 
@@ -1,11 +0,0 @@-name:                p-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal 
@@ -1,11 +0,0 @@-name:                q-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh 
@@ -1,22 +0,0 @@-. ../common.sh--# Create the sandbox-cabal sandbox init--# Add the sources-cabal sandbox add-source p-cabal sandbox add-source q--# delete the directory on disk-rm -R p--# Remove the registered source which is no longer on disk. cabal's handling of-# non-existent sources depends on the behavior of the directory package.-if OUTPUT=`cabal sandbox delete-source p 2>&1`; then-    # 'canonicalizePath' should always succeed with directory >= 1.2.3.0-    echo $OUTPUT | grep 'Success deleting sources: "p"' \-	|| die "Incorrect success message: $OUTPUT"-else-    echo $OUTPUT | grep 'Warning: Source directory not found for paths: "p"' \-	|| die "Incorrect failure message: $OUTPUT"-fi
− tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out 
@@ -1,6 +0,0 @@-Success deleting sources: "p" "q"--Note: 'sandbox delete-source' only unregisters the source dependency, but does-not remove the package from the sandbox package DB.--Use 'sandbox hc-pkg -- unregister' to do that.
− tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh 
@@ -1,11 +0,0 @@-. ../common.sh--# Create the sandbox-cabal sandbox init > /dev/null--# Add the sources-cabal sandbox add-source p > /dev/null-cabal sandbox add-source q > /dev/null--# Remove one of the sources-cabal sandbox delete-source p q
− tests/IntegrationTests/user-config/common.sh 
@@ -1,9 +0,0 @@-# Helper to run Cabal-cabal() {-    "$CABAL" $CABAL_ARGS_NO_CONFIG_FILE "$@"-}--die() {-    echo "die: $@"-    exit 1-}
− tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err 
@@ -1,1 +0,0 @@-RE:^cabal(\.exe)?: \./cabal-config already exists\.$
− tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh 
@@ -1,6 +0,0 @@-. ../common.sh--rm -f ./cabal-config-cabal --config-file=./cabal-config user-config init > /dev/null-cabal --config-file=./cabal-config user-config init-rm -f ./cabal-config
− tests/IntegrationTests/user-config/should_run/overwrites_with_f.out 
@@ -1,2 +0,0 @@-Writing default configuration to ./cabal-config-Writing default configuration to ./cabal-config
− tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh 
@@ -1,9 +0,0 @@-. ../common.sh--rm -f ./cabal-config-cabal --config-file=./cabal-config user-config init \-    || die "Couldn't create config file"-cabal --config-file=./cabal-config user-config -f init \-    || die "Couldn't create config file"-test -e ./cabal-config || die "Config file doesn't exist"-rm -f ./cabal-config
− tests/IntegrationTests/user-config/should_run/runs_without_error.out 
@@ -1,1 +0,0 @@-Writing default configuration to ./cabal-config
− tests/IntegrationTests/user-config/should_run/runs_without_error.sh 
@@ -1,7 +0,0 @@-. ../common.sh--rm -f ./cabal-config-cabal --config-file=./cabal-config user-config init \-    || die "Couldn't create config file"-test -e ./cabal-config || die "Config file doesn't exist"-rm -f ./cabal-config
− tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out 
@@ -1,1 +0,0 @@-Writing default configuration to ./my-config
− tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh 
@@ -1,5 +0,0 @@-. ../common.sh--export CABAL_CONFIG=./my-config-cabal user-config init || die "Couldn't create config file"-test -e ./my-config || die "Config file doesn't exist"
+ tests/IntegrationTests2.hs view
@@ -0,0 +1,1719 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- For the handy instance IsString PackageIdentifier+{-# OPTIONS_GHC -fno-warn-orphans #-}++module IntegrationTests2 where++import Distribution.Client.DistDirLayout+import Distribution.Client.ProjectConfig+import Distribution.Client.Config (defaultCabalDir)+import Distribution.Client.TargetSelector hiding (DirActions(..))+import qualified Distribution.Client.TargetSelector as TS (DirActions(..))+import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.ProjectBuilding+import Distribution.Client.ProjectOrchestration+         ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents )+import Distribution.Client.Types+         ( PackageLocation(..), UnresolvedSourcePackage )+import Distribution.Client.Targets+         ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Solver.Types.SourcePackage as SP+import Distribution.Solver.Types.ConstraintSource+         ( ConstraintSource(ConstraintSourceUnknown) )+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(PackagePropertySource) )++import qualified Distribution.Client.CmdBuild   as CmdBuild+import qualified Distribution.Client.CmdRepl    as CmdRepl+import qualified Distribution.Client.CmdRun     as CmdRun+import qualified Distribution.Client.CmdTest    as CmdTest+import qualified Distribution.Client.CmdBench   as CmdBench+import qualified Distribution.Client.CmdHaddock as CmdHaddock++import Distribution.Package+import Distribution.PackageDescription+import qualified Distribution.Types.GenericPackageDescription as GPG+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags)+import Distribution.Simple.Compiler+import Distribution.System+import Distribution.Version+import Distribution.ModuleName (ModuleName)+import Distribution.Verbosity+import Distribution.Text++import Data.Monoid+import Data.List (sort)+import Data.String (IsString(..))+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad+import Control.Exception hiding (assert)+import System.FilePath+import System.Directory++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options+import Data.Tagged (Tagged(..))+import Data.Proxy  (Proxy(..))+import Data.Typeable (Typeable)+++main :: IO ()+main =+  defaultMainWithIngredients+    (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions])+    (withProjectConfig $ \config ->+      testGroup "Integration tests (internal)"+                (tests config))+++tests :: ProjectConfig -> [TestTree]+tests config =+    --TODO: tests for:+    -- * normal success+    -- * dry-run tests with changes+  [ testGroup "Discovery and planning" $+    [ testCase "find root"      testFindProjectRoot+    , testCase "find root fail" testExceptionFindProjectRoot+    , testCase "no package"    (testExceptionInFindingPackage config)+    , testCase "no package2"   (testExceptionInFindingPackage2 config)+    , testCase "proj conf1"    (testExceptionInProjectConfig config)+    ]+  , testGroup "Target selectors" $+    [ testCaseSteps "valid"             testTargetSelectors+    , testCase      "bad syntax"        testTargetSelectorBadSyntax+    , testCaseSteps "ambiguous syntax"  testTargetSelectorAmbiguous+    , testCase      "no current pkg"    testTargetSelectorNoCurrentPackage+    , testCase      "no targets"        testTargetSelectorNoTargets+    , testCase      "project empty"     testTargetSelectorProjectEmpty+    , testCase      "problems (common)"  (testTargetProblemsCommon config)+    , testCaseSteps "problems (build)"   (testTargetProblemsBuild config)+    , testCaseSteps "problems (repl)"    (testTargetProblemsRepl config)+    , testCaseSteps "problems (run)"     (testTargetProblemsRun config)+    , testCaseSteps "problems (test)"    (testTargetProblemsTest config)+    , testCaseSteps "problems (bench)"   (testTargetProblemsBench config)+    , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config)+    ]+  , testGroup "Exceptions during building (local inplace)" $+    [ testCase "configure"   (testExceptionInConfigureStep config)+    , testCase "build"       (testExceptionInBuildStep config)+--    , testCase "register"   testExceptionInRegisterStep+    ]+    --TODO: need to repeat for packages for the store+    --TODO: need to check we can build sub-libs, foreign libs and exes+    -- components for non-local packages / packages in the store.++  , testGroup "Successful builds" $+    [ testCaseSteps "Setup script styles" (testSetupScriptStyles config)+    , testCase      "keep-going"          (testBuildKeepGoing config)+    ]++  , testGroup "Regression tests" $+    [ testCase "issue #3324" (testRegressionIssue3324 config)+    ]+  ]+++testFindProjectRoot :: Assertion+testFindProjectRoot = do+    Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir)+                                                              (Just testfile)+    file @?= testfile+  where+    testdir  = basedir </> "exception" </> "no-pkg2"+    testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN"+++testExceptionFindProjectRoot :: Assertion+testExceptionFindProjectRoot = do+    Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing+    cwd <- getCurrentDirectory+    dir @?= cwd </> testdir+  where+    testdir = basedir </> "exception" </> "no-pkg2"+++testTargetSelectors :: (String -> IO ()) -> Assertion+testTargetSelectors reportSubCase = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)+                                                       localPackages++    reportSubCase "cwd"+    do Right ts <- readTargetSelectors' []+       ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing]++    reportSubCase "all"+    do Right ts <- readTargetSelectors'+                     ["all", ":all"]+       ts @?= replicate 2 (TargetAllPackages Nothing)++    reportSubCase "filter"+    do Right ts <- readTargetSelectors'+                     [ "libs",  ":cwd:libs"+                     , "flibs", ":cwd:flibs"+                     , "exes",  ":cwd:exes"+                     , "tests", ":cwd:tests"+                     , "benchmarks", ":cwd:benchmarks"]+       zipWithM_ (@?=) ts+         [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind)+         | kind <- concatMap (replicate 2) [LibKind .. ]+         ]++    reportSubCase "all:filter"+    do Right ts <- readTargetSelectors'+                     [ "all:libs",  ":all:libs"+                     , "all:flibs", ":all:flibs"+                     , "all:exes",  ":all:exes"+                     , "all:tests", ":all:tests"+                     , "all:benchmarks", ":all:benchmarks"]+       zipWithM_ (@?=) ts+         [ TargetAllPackages (Just kind)+         | kind <- concatMap (replicate 2) [LibKind .. ]+         ]++    reportSubCase "pkg"+    do Right ts <- readTargetSelectors'+                     [       ":pkg:p", ".",  "./",   "p.cabal"+                     , "q",  ":pkg:q", "q/", "./q/", "q/q.cabal"]+       ts @?= replicate 4 (mkTargetPackage "p-0.1")+           ++ replicate 5 (mkTargetPackage "q-0.1")++    reportSubCase "pkg:filter"+    do Right ts <- readTargetSelectors'+                     [ "p:libs",  ".:libs",  ":pkg:p:libs"+                     , "p:flibs", ".:flibs", ":pkg:p:flibs"+                     , "p:exes",  ".:exes",  ":pkg:p:exes"+                     , "p:tests", ".:tests",  ":pkg:p:tests"+                     , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks"+                     , "q:libs",  "q/:libs", ":pkg:q:libs"+                     , "q:flibs", "q/:flibs", ":pkg:q:flibs"+                     , "q:exes",  "q/:exes", ":pkg:q:exes"+                     , "q:tests", "q/:tests", ":pkg:q:tests"+                     , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"]+       zipWithM_ (@?=) ts $+         [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind)+         | kind <- concatMap (replicate 3) [LibKind .. ]+         ] +++         [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind)+         | kind <- concatMap (replicate 3) [LibKind .. ]+         ]++    reportSubCase "component"+    do Right ts <- readTargetSelectors'+                     [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p"+                     ,      "lib:q", "q:lib:q", ":pkg:q:lib:q" ]+       ts @?= replicate 4 (TargetComponent "p-0.1" CLibName WholeComponent)+           ++ replicate 3 (TargetComponent "q-0.1" CLibName WholeComponent)++    reportSubCase "module"+    do Right ts <- readTargetSelectors'+                     [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P"+                     , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ"+                     , "pexe:PMain" -- p:P or q:QQ would be ambiguous here+                     , "qexe:QMain" -- package p vs component p+                     ]+       ts @?= replicate 4 (TargetComponent "p-0.1" CLibName (ModuleTarget "P"))+           ++ replicate 4 (TargetComponent "q-0.1" CLibName (ModuleTarget "QQ"))+           ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain")+              , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain")+              ]++    reportSubCase "file"+    do Right ts <- readTargetSelectors'+                     [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc",+                                 ":pkg:p:lib:p:file:P.y"+                     , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc",+                                  ":pkg:q:lib:q:file:QQ.y"+                     ]+       ts @?= replicate 5 (TargetComponent "p-0.1" CLibName (FileTarget "P"))+           ++ replicate 5 (TargetComponent "q-0.1" CLibName (FileTarget "QQ"))+       -- Note there's a bit of an inconsistency here: for the single-part+       -- syntax the target has to point to a file that exists, whereas for+       -- all the other forms we don't require that.++    cleanProject testdir+  where+    testdir = "targets/simple"+    config  = mempty+++testTargetSelectorBadSyntax :: Assertion+testTargetSelectorBadSyntax = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let targets = [ "foo bar",  " foo"+                  , "foo:", "foo::bar"+                  , "foo: ", "foo: :bar"+                  , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ]+    Left errs <- readTargetSelectors localPackages targets+    zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets)+    cleanProject testdir+  where+    testdir = "targets/empty"+    config  = mempty+++testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion+testTargetSelectorAmbiguous reportSubCase = do++    -- 'all' is ambiguous with packages and cwd components+    reportSubCase "ambiguous: all vs pkg"+    assertAmbiguous "all"+      [mkTargetPackage "all", mkTargetAllPackages]+      [mkpkg "all" []]++    reportSubCase "ambiguous: all vs cwd component"+    assertAmbiguous "all"+      [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages]+      [mkpkg "other" [mkexe "all"]]++    -- but 'all' is not ambiguous with non-cwd components, modules or files+    reportSubCase "unambiguous: all vs non-cwd comp, mod, file"+    assertUnambiguous "All"+      mkTargetAllPackages+      [ mkpkgAt "foo" [mkexe "All"] "foo"+      , mkpkg   "bar" [ mkexe "bar" `withModules` ["All"]+                      , mkexe "baz" `withCFiles` ["All"] ]+      ]++    -- filters 'libs', 'exes' etc are ambiguous with packages and+    -- local components+    reportSubCase "ambiguous: cwd-pkg filter vs pkg"+    assertAmbiguous "libs"+      [ mkTargetPackage "libs"+      , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ]+      [mkpkg "libs" []]++    reportSubCase "ambiguous: filter vs cwd component"+    assertAmbiguous "exes"+      [ mkTargetComponent "other" (CExeName "exes")+      , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ]+      [mkpkg "other" [mkexe "exes"]]++    -- but filters are not ambiguous with non-cwd components, modules or files+    reportSubCase "unambiguous: filter vs non-cwd comp, mod, file"+    assertUnambiguous "Libs"+      (TargetPackage TargetImplicitCwd "bar" (Just LibKind))+      [ mkpkgAt "foo" [mkexe "Libs"] "foo"+      , mkpkg   "bar" [ mkexe "bar" `withModules` ["Libs"]+                      , mkexe "baz" `withCFiles` ["Libs"] ]+      ]++    -- local components shadow packages and other components+    reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp"+    assertUnambiguous "foo"+      (mkTargetComponent "other" (CExeName "foo"))+      [ mkpkg   "other"  [mkexe "foo"]+      , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo+      , mkpkg "foo" [] ]                        -- shadows package foo++    -- local components shadow modules and files+    reportSubCase "unambiguous: cwd comp vs module, file"+    assertUnambiguous "Foo"+      (mkTargetComponent "bar" (CExeName "Foo"))+      [ mkpkg "bar" [mkexe "Foo"]+      , mkpkg "other" [ mkexe "other"  `withModules` ["Foo"]+                      , mkexe "other2" `withCFiles`  ["Foo"] ]+      ]++    -- packages shadow non-local components+    reportSubCase "unambiguous: pkg vs non-cwd comp"+    assertUnambiguous "foo"+      (mkTargetPackage "foo")+      [ mkpkg "foo" []+      , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo+      ]++    -- packages shadow modules and files+    reportSubCase "unambiguous: pkg vs module, file"+    assertUnambiguous "Foo"+      (mkTargetPackage "Foo")+      [ mkpkgAt "Foo" [] "foo"+      , mkpkg "other" [ mkexe "other"  `withModules` ["Foo"]+                      , mkexe "other2" `withCFiles`  ["Foo"] ]+      ]++    -- non-exact case packages and components are ambiguous+    reportSubCase "ambiguous: non-exact-case pkg names"+    assertAmbiguous "Foo"+      [ mkTargetPackage "foo", mkTargetPackage "FOO" ]+      [ mkpkg "foo" [], mkpkg "FOO" [] ]+    reportSubCase "ambiguous: non-exact-case comp names"+    assertAmbiguous "Foo"+      [ mkTargetComponent "bar" (CExeName "foo")+      , mkTargetComponent "bar" (CExeName "FOO") ]+      [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ]++    -- exact-case Module or File over non-exact case package or component+    reportSubCase "unambiguous: module vs non-exact-case pkg, comp"+    assertUnambiguous "Baz"+      (mkTargetModule "other" (CExeName "other") "Baz")+      [ mkpkg "baz" [mkexe "BAZ"]+      , mkpkg "other" [ mkexe "other"  `withModules` ["Baz"] ]+      ]+    reportSubCase "unambiguous: file vs non-exact-case pkg, comp"+    assertUnambiguous "Baz"+      (mkTargetFile "other" (CExeName "other") "Baz")+      [ mkpkg "baz" [mkexe "BAZ"]+      , mkpkg "other" [ mkexe "other"  `withCFiles` ["Baz"] ]+      ]+  where+    assertAmbiguous :: String+                    -> [TargetSelector PackageId]+                    -> [SourcePackage (PackageLocation a)]+                    -> Assertion+    assertAmbiguous str tss pkgs = do+      res <- readTargetSelectorsWith fakeDirActions pkgs [str]+      case res of+        Left [TargetSelectorAmbiguous _ tss'] ->+          sort (map snd tss') @?= sort tss+        _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], "+                          ++ "got " ++ show res++    assertUnambiguous :: String+                      -> TargetSelector PackageId+                      -> [SourcePackage (PackageLocation a)]+                      -> Assertion+    assertUnambiguous str ts pkgs = do+      res <- readTargetSelectorsWith fakeDirActions pkgs [str]+      case res of+        Right [ts'] -> ts' @?= ts+        _ -> assertFailure $ "expected Right [Target...], "+                          ++ "got " ++ show res++    fakeDirActions = TS.DirActions {+      TS.doesFileExist       = \_p -> return True,+      TS.doesDirectoryExist  = \_p -> return True,+      TS.canonicalizePath    = \p -> return ("/" </> p), -- FilePath.Unix.</> ?+      TS.getCurrentDirectory = return "/"+    }++    mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a)+    mkpkg pkgidstr exes = mkpkgAt pkgidstr exes ""++    mkpkgAt :: String -> [Executable] -> FilePath+            -> SourcePackage (PackageLocation a)+    mkpkgAt pkgidstr exes loc =+      SourcePackage {+        packageInfoId = pkgid,+        packageSource = LocalUnpackedPackage loc,+        packageDescrOverride  = Nothing,+        SP.packageDescription = GenericPackageDescription {+          GPG.packageDescription = emptyPackageDescription { package = pkgid },+          genPackageFlags    = [],+          condLibrary        = Nothing,+          condSubLibraries   = [],+          condForeignLibs    = [],+          condExecutables    = [ ( exeName exe, CondNode exe [] [] )+                               | exe <- exes ],+          condTestSuites     = [],+          condBenchmarks     = []+        }+      }+      where+        Just pkgid = simpleParse pkgidstr++    mkexe :: String -> Executable+    mkexe name = mempty { exeName = fromString name }++    withModules :: Executable -> [String] -> Executable+    withModules exe mods =+      exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } }++    withCFiles :: Executable -> [FilePath] -> Executable+    withCFiles exe files =+      exe { buildInfo = (buildInfo exe) { cSources = files } }+++mkTargetPackage :: PackageId -> TargetSelector PackageId+mkTargetPackage pkgid =+    TargetPackage TargetExplicitNamed pkgid Nothing++mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId+mkTargetComponent pkgid cname =+    TargetComponent pkgid cname WholeComponent++mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId+mkTargetModule pkgid cname mname =+    TargetComponent pkgid cname (ModuleTarget mname)++mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId+mkTargetFile pkgid cname fname =+    TargetComponent pkgid cname (FileTarget fname)++mkTargetAllPackages :: TargetSelector PackageId+mkTargetAllPackages = TargetAllPackages Nothing++instance IsString PackageIdentifier where+    fromString pkgidstr = pkgid+      where Just pkgid = simpleParse pkgidstr+++testTargetSelectorNoCurrentPackage :: Assertion+testTargetSelectorNoCurrentPackage = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)+                                                       localPackages+        targets = [ "libs",  ":cwd:libs"+                  , "flibs", ":cwd:flibs"+                  , "exes",  ":cwd:exes"+                  , "tests", ":cwd:tests"+                  , "benchmarks", ":cwd:benchmarks"]+    Left errs <- readTargetSelectors' targets+    zipWithM_ (@?=) errs+      [ TargetSelectorNoCurrentPackage ts+      | target <- targets+      , let Just ts = parseTargetString target+      ]+    cleanProject testdir+  where+    testdir = "targets/complex"+    config  = mempty+++testTargetSelectorNoTargets :: Assertion+testTargetSelectorNoTargets = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    Left errs <- readTargetSelectors localPackages []+    errs @?= [TargetSelectorNoTargetsInCwd]+    cleanProject testdir+  where+    testdir = "targets/complex"+    config  = mempty+++testTargetSelectorProjectEmpty :: Assertion+testTargetSelectorProjectEmpty = do+    (_, _, _, localPackages, _) <- configureProject testdir config+    Left errs <- readTargetSelectors localPackages []+    errs @?= [TargetSelectorNoTargetsInProject]+    cleanProject testdir+  where+    testdir = "targets/empty"+    config  = mempty+++testTargetProblemsCommon :: ProjectConfig -> Assertion+testTargetProblemsCommon config0 = do+    (_,elaboratedPlan,_) <- planProject testdir config++    let pkgIdMap :: Map.Map PackageName PackageId+        pkgIdMap = Map.fromList+                     [ (packageName p, packageId p)+                     | p <- InstallPlan.toList elaboratedPlan ]++        cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem+                  , TargetSelector PackageId+                  )]+        cases =+          [ -- Cannot resolve packages outside of the project+            ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetProblemNoSuchPackage "foobar"+            , mkTargetPackage "foobar" )++            -- We cannot currently build components like testsuites or+            -- benchmarks from packages that are not local to the project+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetComponentNotProjectLocal+                      (pkgIdMap Map.! "filepath") (CTestName "filepath-tests")+                      WholeComponent+            , mkTargetComponent (pkgIdMap Map.! "filepath")+                                (CTestName "filepath-tests") )++            -- Components can be explicitly @buildable: False@+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent+            , mkTargetComponent "q-0.1" (CExeName "buildable-false") )++            -- Testsuites and benchmarks can be disabled by the solver if it+            -- cannot satisfy deps+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent+            , mkTargetComponent "q-0.1" (CTestName "solver-disabled") )++            -- Testsuites and benchmarks can be disabled explicitly by the+            -- user via config+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetOptionalStanzaDisabledByUser+                      "q-0.1" (CBenchName "user-disabled") WholeComponent+            , mkTargetComponent "q-0.1" (CBenchName "user-disabled") )++            -- An unknown package. The target selector resolution should only+            -- produce known packages, so this should not happen with the+            -- output from 'readTargetSelectors'.+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetProblemNoSuchPackage "foobar"+            , mkTargetPackage "foobar" )++            -- An unknown component of a known package. The target selector+            -- resolution should only produce known packages, so this should+            -- not happen with the output from 'readTargetSelectors'.+          , ( \_ -> CmdBuild.TargetProblemCommon $+                    TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such")+            , mkTargetComponent "q-0.1" (CExeName "no-such") )+          ]+    assertTargetProblems+      elaboratedPlan+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      CmdBuild.TargetProblemCommon+      cases+  where+    testdir = "targets/complex"+    config  = config0 {+      projectConfigLocalPackages = (projectConfigLocalPackages config0) {+        packageConfigBenchmarks = toFlag False+      }+    , projectConfigShared = (projectConfigShared config0) {+        projectConfigConstraints =+          [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource+           , ConstraintSourceUnknown )]+      }+    }+++testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsBuild config reportSubCase = do++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      CmdBuild.TargetProblemCommon+      [ ( CmdBuild.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "all-disabled"+    assertProjectTargetProblems+      "targets/all-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigBenchmarks = toFlag False+        }+      }+      CmdBuild.selectPackageTargets+      CmdBuild.selectComponentTarget+      CmdBuild.TargetProblemCommon+      [ ( flip CmdBuild.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CExeName "buildable-false")+                                 TargetNotBuildable True+               , AvailableTarget "p-0.1" CLibName+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "enabled component kinds"+    -- When we explicitly enable all the component kinds then selecting the+    -- whole package selects those component kinds too+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config {+           projectConfigLocalPackages = (projectConfigLocalPackages config) {+             packageConfigTests      = toFlag True,+             packageConfigBenchmarks = toFlag True+           }+         }+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         CmdBuild.TargetProblemCommon+         [ mkTargetPackage "p-0.1" ]+         [ ("p-0.1-inplace",             CLibName)+         , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+         , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+         , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+         , ("p-0.1-inplace-libp",        CFLibName  "libp")+         ]++    reportSubCase "disabled component kinds"+    -- When we explicitly disable all the component kinds then selecting the+    -- whole package only selects the library, foreign lib and exes+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config {+           projectConfigLocalPackages = (projectConfigLocalPackages config) {+             packageConfigTests      = toFlag False,+             packageConfigBenchmarks = toFlag False+           }+         }+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         CmdBuild.TargetProblemCommon+         [ mkTargetPackage "p-0.1" ]+         [ ("p-0.1-inplace",        CLibName)+         , ("p-0.1-inplace-an-exe", CExeName  "an-exe")+         , ("p-0.1-inplace-libp",   CFLibName "libp")+         ]++    reportSubCase "requested component kinds"+    -- When we selecting the package with an explicit filter then we get those+    -- components even though we did not explicitly enable tests/benchmarks+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdBuild.selectPackageTargets+         CmdBuild.selectComponentTarget+         CmdBuild.TargetProblemCommon+         [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind)+         , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind)+         ]+         [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+         , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+         ]+++testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsRepl config reportSubCase = do++    reportSubCase "multiple-libs"+    assertProjectTargetProblems+      "targets/multiple-libs" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemMatchesMultiple+               [ AvailableTarget "p-0.1" CLibName+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "q-0.1" CLibName+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetAllPackages )+      ]++    reportSubCase "multiple-exes"+    assertProjectTargetProblems+      "targets/multiple-exes" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemMatchesMultiple+               [ AvailableTarget "p-0.1" (CExeName "p2")+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "p-0.1" (CExeName "p1")+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "multiple-tests"+    assertProjectTargetProblems+      "targets/multiple-tests" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemMatchesMultiple+               [ AvailableTarget "p-0.1" (CTestName "p2")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               , AvailableTarget "p-0.1" (CTestName "p1")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               ]+        , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) )+      ]++    reportSubCase "multiple targets"+    do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         CmdRepl.TargetProblemCommon+         [ mkTargetComponent "p-0.1" (CExeName "p1")+         , mkTargetComponent "p-0.1" (CExeName "p2")+         ]+         [ ("p-0.1-inplace-p1", CExeName "p1")+         , ("p-0.1-inplace-p2", CExeName "p2")+         ]++    reportSubCase "libs-disabled"+    assertProjectTargetProblems+      "targets/libs-disabled" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" CLibName TargetNotBuildable True ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "exes-disabled"+    assertProjectTargetProblems+      "targets/exes-disabled" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "test-only"+    assertProjectTargetProblems+      "targets/test-only" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( flip CmdRepl.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "pexe")+                   (TargetBuildable () TargetNotRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdRepl.selectPackageTargets+      CmdRepl.selectComponentTarget+      CmdRepl.TargetProblemCommon+      [ ( CmdRepl.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "requested component kinds"+    do (_,elaboratedPlan,_) <- planProject "targets/variety" config+       -- by default we only get the lib+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         CmdRepl.TargetProblemCommon+         [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ]+         [ ("p-0.1-inplace", CLibName) ]+       -- When we select the package with an explicit filter then we get those+       -- components even though we did not explicitly enable tests/benchmarks+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         CmdRepl.TargetProblemCommon+         [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ]+         [ ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite") ]+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRepl.selectPackageTargets+         CmdRepl.selectComponentTarget+         CmdRepl.TargetProblemCommon+         [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ]+         [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ]+++testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsRun config reportSubCase = do++    reportSubCase "multiple-exes"+    assertProjectTargetProblems+      "targets/multiple-exes" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      CmdRun.TargetProblemCommon+      [ ( flip CmdRun.TargetProblemMatchesMultiple+               [ AvailableTarget "p-0.1" (CExeName "p2")+                   (TargetBuildable () TargetRequestedByDefault) True+               , AvailableTarget "p-0.1" (CExeName "p1")+                   (TargetBuildable () TargetRequestedByDefault) True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "multiple targets"+    do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config+       assertProjectDistinctTargets+         elaboratedPlan+         CmdRun.selectPackageTargets+         CmdRun.selectComponentTarget+         CmdRun.TargetProblemCommon+         [ mkTargetComponent "p-0.1" (CExeName "p1")+         , mkTargetComponent "p-0.1" (CExeName "p2")+         ]+         [ ("p-0.1-inplace-p1", CExeName "p1")+         , ("p-0.1-inplace-p2", CExeName "p2")+         ]++    reportSubCase "exes-disabled"+    assertProjectTargetProblems+      "targets/exes-disabled" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      CmdRun.TargetProblemCommon+      [ ( flip CmdRun.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      CmdRun.TargetProblemCommon+      [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "test-only"+    assertProjectTargetProblems+      "targets/test-only" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      CmdRun.TargetProblemCommon+      [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "variety"+    assertProjectTargetProblems+      "targets/variety" config+      CmdRun.selectPackageTargets+      CmdRun.selectComponentTarget+      CmdRun.TargetProblemCommon $+      [ ( const (CmdRun.TargetProblemComponentNotExe "p-0.1" cname)+        , mkTargetComponent "p-0.1" cname )+      | cname <- [ CLibName, CFLibName "libp",+                   CTestName "a-testsuite", CBenchName "a-benchmark" ]+      ] +++      [ ( const (CmdRun.TargetProblemIsSubComponent+                          "p-0.1" cname (ModuleTarget modname))+        , mkTargetModule "p-0.1" cname modname )+      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")+                            , (CBenchName "a-benchmark", "BenchModule")+                            , (CExeName   "an-exe",      "ExeModule")+                            , (CLibName,                 "P")+                            ]+      ] +++      [ ( const (CmdRun.TargetProblemIsSubComponent+                          "p-0.1" cname (FileTarget fname))+        , mkTargetFile "p-0.1" cname fname)+      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")+                          , (CBenchName "a-benchmark", "Bench.hs")+                          , (CExeName   "an-exe",      "Main.hs")+                          ]+      ]+++testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsTest config reportSubCase = do++    reportSubCase "disabled by config"+    assertProjectTargetProblems+      "targets/tests-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigTests = toFlag False+        }+      }+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      CmdTest.TargetProblemCommon+      [ ( flip CmdTest.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledByUser True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "disabled by solver & buildable false"+    assertProjectTargetProblems+      "targets/tests-disabled"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      CmdTest.TargetProblemCommon+      [ ( flip CmdTest.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CTestName "user-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               ]+        , mkTargetPackage "p-0.1" )++      , ( flip CmdTest.TargetProblemNoneEnabled+               [ AvailableTarget "q-0.1" (CTestName "buildable-false")+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "q-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      CmdTest.TargetProblemCommon+      [ ( CmdTest.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "no tests"+    assertProjectTargetProblems+      "targets/simple"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      CmdTest.TargetProblemCommon+      [ ( CmdTest.TargetProblemNoTests, mkTargetPackage "p-0.1" )+      , ( CmdTest.TargetProblemNoTests, mkTargetPackage "q-0.1" )+      ]++    reportSubCase "not a test"+    assertProjectTargetProblems+      "targets/variety"+      config+      CmdTest.selectPackageTargets+      CmdTest.selectComponentTarget+      CmdTest.TargetProblemCommon $+      [ ( const (CmdTest.TargetProblemComponentNotTest+                  "p-0.1" CLibName)+        , mkTargetComponent "p-0.1" CLibName )++      , ( const (CmdTest.TargetProblemComponentNotTest+                  "p-0.1" (CExeName "an-exe"))+        , mkTargetComponent "p-0.1" (CExeName "an-exe") )++      , ( const (CmdTest.TargetProblemComponentNotTest+                  "p-0.1" (CFLibName "libp"))+        , mkTargetComponent "p-0.1" (CFLibName "libp") )++      , ( const (CmdTest.TargetProblemComponentNotTest+                  "p-0.1" (CBenchName "a-benchmark"))+        , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") )+      ] +++      [ ( const (CmdTest.TargetProblemIsSubComponent+                          "p-0.1" cname (ModuleTarget modname))+        , mkTargetModule "p-0.1" cname modname )+      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")+                            , (CBenchName "a-benchmark", "BenchModule")+                            , (CExeName   "an-exe",      "ExeModule")+                            , (CLibName,                 "P")+                            ]+      ] +++      [ ( const (CmdTest.TargetProblemIsSubComponent+                          "p-0.1" cname (FileTarget fname))+        , mkTargetFile "p-0.1" cname fname)+      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")+                          , (CBenchName "a-benchmark", "Bench.hs")+                          , (CExeName   "an-exe",      "Main.hs")+                          ]+      ]+++testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsBench config reportSubCase = do++    reportSubCase "disabled by config"+    assertProjectTargetProblems+      "targets/benchmarks-disabled"+      config {+        projectConfigLocalPackages = (projectConfigLocalPackages config) {+          packageConfigBenchmarks = toFlag False+        }+      }+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      CmdBench.TargetProblemCommon+      [ ( flip CmdBench.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CBenchName "solver-disabled")+                                 TargetDisabledByUser True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "disabled by solver & buildable false"+    assertProjectTargetProblems+      "targets/benchmarks-disabled"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      CmdBench.TargetProblemCommon+      [ ( flip CmdBench.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CBenchName "solver-disabled")+                                 TargetDisabledBySolver True+               ]+        , mkTargetPackage "p-0.1" )++      , ( flip CmdBench.TargetProblemNoneEnabled+               [ AvailableTarget "q-0.1" (CBenchName "buildable-false")+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "q-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      CmdBench.TargetProblemCommon+      [ ( CmdBench.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "no benchmarks"+    assertProjectTargetProblems+      "targets/simple"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      CmdBench.TargetProblemCommon+      [ ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "p-0.1" )+      , ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "q-0.1" )+      ]++    reportSubCase "not a benchmark"+    assertProjectTargetProblems+      "targets/variety"+      config+      CmdBench.selectPackageTargets+      CmdBench.selectComponentTarget+      CmdBench.TargetProblemCommon $+      [ ( const (CmdBench.TargetProblemComponentNotBenchmark+                  "p-0.1" CLibName)+        , mkTargetComponent "p-0.1" CLibName )++      , ( const (CmdBench.TargetProblemComponentNotBenchmark+                  "p-0.1" (CExeName "an-exe"))+        , mkTargetComponent "p-0.1" (CExeName "an-exe") )++      , ( const (CmdBench.TargetProblemComponentNotBenchmark+                  "p-0.1" (CFLibName "libp"))+        , mkTargetComponent "p-0.1" (CFLibName "libp") )++      , ( const (CmdBench.TargetProblemComponentNotBenchmark+                  "p-0.1" (CTestName "a-testsuite"))+        , mkTargetComponent "p-0.1" (CTestName "a-testsuite") )+      ] +++      [ ( const (CmdBench.TargetProblemIsSubComponent+                          "p-0.1" cname (ModuleTarget modname))+        , mkTargetModule "p-0.1" cname modname )+      | (cname, modname) <- [ (CTestName  "a-testsuite", "TestModule")+                            , (CBenchName "a-benchmark", "BenchModule")+                            , (CExeName   "an-exe",      "ExeModule")+                            , (CLibName,                 "P")+                            ]+      ] +++      [ ( const (CmdBench.TargetProblemIsSubComponent+                          "p-0.1" cname (FileTarget fname))+        , mkTargetFile "p-0.1" cname fname)+      | (cname, fname) <- [ (CTestName  "a-testsuite", "Test.hs")+                          , (CBenchName "a-benchmark", "Bench.hs")+                          , (CExeName   "an-exe",      "Main.hs")+                          ]+      ]+++testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion+testTargetProblemsHaddock config reportSubCase = do++    reportSubCase "all-disabled"+    assertProjectTargetProblems+      "targets/all-disabled"+      config+      (let haddockFlags = mkHaddockFlags False True True False+        in CmdHaddock.selectPackageTargets haddockFlags)+      CmdHaddock.selectComponentTarget+      CmdHaddock.TargetProblemCommon+      [ ( flip CmdHaddock.TargetProblemNoneEnabled+               [ AvailableTarget "p-0.1" (CBenchName "user-disabled")+                                 TargetDisabledByUser True+               , AvailableTarget "p-0.1" (CTestName "solver-disabled")+                                 TargetDisabledBySolver True+               , AvailableTarget "p-0.1" (CExeName "buildable-false")+                                 TargetNotBuildable True+               , AvailableTarget "p-0.1" CLibName+                                 TargetNotBuildable True+               ]+        , mkTargetPackage "p-0.1" )+      ]++    reportSubCase "empty-pkg"+    assertProjectTargetProblems+      "targets/empty-pkg" config+      (let haddockFlags = mkHaddockFlags False False False False+        in CmdHaddock.selectPackageTargets haddockFlags)+      CmdHaddock.selectComponentTarget+      CmdHaddock.TargetProblemCommon+      [ ( CmdHaddock.TargetProblemNoTargets, mkTargetPackage "p-0.1" )+      ]++    reportSubCase "enabled component kinds"+    -- When we explicitly enable all the component kinds then selecting the+    -- whole package selects those component kinds too+    (_,elaboratedPlan,_) <- planProject "targets/variety" config+    let haddockFlags = mkHaddockFlags True True True True+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          CmdHaddock.TargetProblemCommon+          [ mkTargetPackage "p-0.1" ]+          [ ("p-0.1-inplace",             CLibName)+          , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+          , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+          , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+          , ("p-0.1-inplace-libp",        CFLibName  "libp")+          ]++    reportSubCase "disabled component kinds"+    -- When we explicitly disable all the component kinds then selecting the+    -- whole package only selects the library+    let haddockFlags = mkHaddockFlags False False False False+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          CmdHaddock.TargetProblemCommon+          [ mkTargetPackage "p-0.1" ]+          [ ("p-0.1-inplace", CLibName) ]++    reportSubCase "requested component kinds"+    -- When we selecting the package with an explicit filter then it does not+    -- matter if the config was to disable all the component kinds+    let haddockFlags = mkHaddockFlags False False False False+     in assertProjectDistinctTargets+          elaboratedPlan+          (CmdHaddock.selectPackageTargets haddockFlags)+          CmdHaddock.selectComponentTarget+          CmdHaddock.TargetProblemCommon+          [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind)+          , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind)+          , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind)+          , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind)+          ]+          [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")+          , ("p-0.1-inplace-a-testsuite", CTestName  "a-testsuite")+          , ("p-0.1-inplace-an-exe",      CExeName   "an-exe")+          , ("p-0.1-inplace-libp",        CFLibName  "libp")+          ]+  where+    mkHaddockFlags flib exe test bench =+      defaultHaddockFlags {+        haddockForeignLibs = toFlag flib,+        haddockExecutables = toFlag exe,+        haddockTestSuites  = toFlag test,+        haddockBenchmarks  = toFlag bench+      }++assertProjectDistinctTargets+  :: forall err. (Eq err, Show err) =>+     ElaboratedInstallPlan+  -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k])+  -> (forall k. PackageId -> ComponentName -> SubComponentTarget ->  AvailableTarget k  -> Either err  k )+  -> (TargetProblemCommon -> err)+  -> [TargetSelector PackageId]+  -> [(UnitId, ComponentName)]+  -> Assertion+assertProjectDistinctTargets elaboratedPlan+                             selectPackageTargets+                             selectComponentTarget+                             liftProblem+                             targetSelectors+                             expectedTargets+  | Right targets <- results+  = distinctTargetComponents targets @?= Set.fromList expectedTargets++  | otherwise+  = assertFailure $ "assertProjectDistinctTargets: expected "+                 ++ "(Right targets) but got " ++ show results+  where+    results = resolveTargets+                selectPackageTargets+                selectComponentTarget+                liftProblem+                elaboratedPlan+                targetSelectors+++assertProjectTargetProblems+  :: forall err. (Eq err, Show err) =>+     FilePath -> ProjectConfig+  -> (forall k. TargetSelector PackageId+             -> [AvailableTarget k]+             -> Either err [k])+  -> (forall k. PackageId -> ComponentName -> SubComponentTarget+             -> AvailableTarget k+             -> Either err k )+  -> (TargetProblemCommon -> err)+  -> [(TargetSelector PackageId -> err, TargetSelector PackageId)]+  -> Assertion+assertProjectTargetProblems testdir config+                            selectPackageTargets+                            selectComponentTarget+                            liftProblem+                            cases = do+    (_,elaboratedPlan,_) <- planProject testdir config+    assertTargetProblems+      elaboratedPlan+      selectPackageTargets+      selectComponentTarget+      liftProblem+      cases+++assertTargetProblems+  :: forall err. (Eq err, Show err) =>+     ElaboratedInstallPlan+  -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k])+  -> (forall k. PackageId -> ComponentName -> SubComponentTarget ->  AvailableTarget k  -> Either err  k )+  -> (TargetProblemCommon -> err)+  -> [(TargetSelector PackageId -> err, TargetSelector PackageId)]+  -> Assertion+assertTargetProblems elaboratedPlan+                     selectPackageTargets+                     selectComponentTarget+                     liftProblem =+    mapM_ (uncurry assertTargetProblem)+  where+    assertTargetProblem expected targetSelector =+      let res = resolveTargets selectPackageTargets selectComponentTarget+                               liftProblem elaboratedPlan [targetSelector] in+      case res of+        Left [problem] ->+          problem @?= expected targetSelector++        unexpected ->+          assertFailure $ "expected resolveTargets result: (Left [problem]) "+                       ++ "but got: " ++ show unexpected+++testExceptionInFindingPackage :: ProjectConfig -> Assertion+testExceptionInFindingPackage config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadLocGlobEmptyMatch "./*.cabal"] -> return ()+      _ -> assertFailure "expected BadLocGlobEmptyMatch"+    cleanProject testdir+  where+    testdir = "exception/no-pkg"+++testExceptionInFindingPackage2 :: ProjectConfig -> Assertion+testExceptionInFindingPackage2 config = do+    BadPackageLocations _ locs <- expectException "BadPackageLocations" $+      void $ planProject testdir config+    case locs of+      [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return ()+      _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs+    cleanProject testdir+  where+    testdir = "exception/no-pkg2"+++testExceptionInProjectConfig :: ProjectConfig -> Assertion+testExceptionInProjectConfig config = do+    BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $+      void $ planProject testdir config+    case ps of+      [(pn,"ghc")] | "foo" == pn -> return ()+      _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got "+                        ++ show ps+    cleanProject testdir+  where+    testdir = "exception/bad-config"+++testExceptionInConfigureStep :: ProjectConfig -> Assertion+testExceptionInConfigureStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    case buildFailureReason failure of+      ConfigureFailed _ -> return ()+      _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure +    cleanProject testdir+  where+    testdir = "exception/configure"+    pkgidA1 = PackageIdentifier "a" (mkVersion [1])+++testExceptionInBuildStep :: ProjectConfig -> Assertion+testExceptionInBuildStep config = do+    (plan, res) <- executePlan =<< planProject testdir config+    (_pkga1, failure) <- expectPackageFailed plan res pkgidA1+    expectBuildFailed failure+  where+    testdir = "exception/build"+    pkgidA1 = PackageIdentifier "a" (mkVersion [1])++testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion+testSetupScriptStyles config reportSubCase = do++  reportSubCase (show SetupCustomExplicitDeps)++  plan0@(_,_,sharedConfig) <- planProject testdir1 config++  let isOSX (Platform _ OSX) = True+      isOSX _ = False+  -- Skip the Custom tests when the shipped Cabal library is buggy+  unless (isOSX (pkgConfigPlatform sharedConfig)+       && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do++    (plan1, res1) <- executePlan plan0+    (pkg1,  _)    <- expectPackageInstalled plan1 res1 pkgidA+    elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps+    hasDefaultSetupDeps pkg1 @?= Just False+    marker1 <- readFile (basedir </> testdir1 </> "marker")+    marker1 @?= "ok"+    removeFile (basedir </> testdir1 </> "marker")++    reportSubCase (show SetupCustomImplicitDeps)+    (plan2, res2) <- executePlan =<< planProject testdir2 config+    (pkg2,  _)    <- expectPackageInstalled plan2 res2 pkgidA+    elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps+    hasDefaultSetupDeps pkg2 @?= Just True+    marker2 <- readFile (basedir </> testdir2 </> "marker")+    marker2 @?= "ok"+    removeFile (basedir </> testdir2 </> "marker")++    reportSubCase (show SetupNonCustomInternalLib)+    (plan3, res3) <- executePlan =<< planProject testdir3 config+    (pkg3,  _)    <- expectPackageInstalled plan3 res3 pkgidA+    elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib+{-+    --TODO: the SetupNonCustomExternalLib case is hard to test since it+    -- requires a version of Cabal that's later than the one we're testing+    -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0+    -- and a corresponding Cabal package that we can use to try and build a+    -- default Setup.hs.+    reportSubCase (show SetupNonCustomExternalLib)+    (plan4, res4) <- executePlan =<< planProject testdir4 config+    (pkg4,  _)    <- expectPackageInstalled plan4 res4 pkgidA+    pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib+-}+  where+    testdir1 = "build/setup-custom1"+    testdir2 = "build/setup-custom2"+    testdir3 = "build/setup-simple"+    pkgidA   = PackageIdentifier "a" (mkVersion [0,1])+    -- The solver fills in default setup deps explicitly, but marks them as such+    hasDefaultSetupDeps = fmap defaultSetupDepends+                        . setupBuildInfo . elabPkgDescription++-- | Test the behaviour with and without @--keep-going@+--+testBuildKeepGoing :: ProjectConfig -> Assertion+testBuildKeepGoing config = do+    -- P is expected to fail, Q does not depend on P but without+    -- parallel build and without keep-going then we don't build Q yet.+    (plan1, res1) <- executePlan =<< planProject testdir (config  <> keepGoing False)+    (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1"+    expectBuildFailed failure1+    _ <- expectPackageConfigured plan1 res1 "q-0.1"++    -- With keep-going then we should go on to sucessfully build Q+    (plan2, res2) <- executePlan+                 =<< planProject testdir (config <> keepGoing True)+    (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1"+    expectBuildFailed failure2+    _ <- expectPackageInstalled plan2 res2 "q-0.1"+    return ()+  where+    testdir = "build/keep-going"+    keepGoing kg =+      mempty {+        projectConfigBuildOnly = mempty {+          projectConfigKeepGoing = toFlag kg+        }+      }++-- | See <https://github.com/haskell/cabal/issues/3324>+--+testRegressionIssue3324 :: ProjectConfig -> Assertion+testRegressionIssue3324 config = do+    -- expected failure first time due to missing dep+    (plan1, res1) <- executePlan =<< planProject testdir config+    (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1"+    expectBuildFailed failure++    -- add the missing dep, now it should work+    let qcabal  = basedir </> testdir </> "q" </> "q.cabal"+    withFileFinallyRestore qcabal $ do+      appendFile qcabal ("  build-depends: p\n")+      (plan2, res2) <- executePlan =<< planProject testdir config+      _ <- expectPackageInstalled plan2 res2 "p-0.1"+      _ <- expectPackageInstalled plan2 res2 "q-0.1"+      return ()+  where+    testdir = "regression/3324"+++---------------------------------+-- Test utils to plan and build+--++basedir :: FilePath+basedir = "tests" </> "IntegrationTests2"++dirActions :: FilePath -> TS.DirActions IO+dirActions testdir =+    defaultDirActions {+      TS.doesFileExist       = \p ->+        TS.doesFileExist defaultDirActions (virtcwd </> p),++      TS.doesDirectoryExist  = \p ->+        TS.doesDirectoryExist defaultDirActions (virtcwd </> p),++      TS.canonicalizePath    = \p ->+        TS.canonicalizePath defaultDirActions (virtcwd </> p),++      TS.getCurrentDirectory =+        TS.canonicalizePath defaultDirActions virtcwd+    }+  where+    virtcwd = basedir </> testdir++type ProjDetails = (DistDirLayout,+                    CabalDirLayout,+                    ProjectConfig,+                    [UnresolvedSourcePackage],+                    BuildTimeSettings)++configureProject :: FilePath -> ProjectConfig -> IO ProjDetails+configureProject testdir cliConfig = do+    cabalDir <- defaultCabalDir+    let cabalDirLayout = defaultCabalDirLayout cabalDir++    projectRootDir <- canonicalizePath (basedir </> testdir)+    isexplict      <- doesFileExist (projectRootDir </> "cabal.project")+    let projectRoot+          | isexplict = ProjectRootExplicit projectRootDir+                                           (projectRootDir </> "cabal.project")+          | otherwise = ProjectRootImplicit projectRootDir+        distDirLayout = defaultDistDirLayout projectRoot Nothing++    -- Clear state between test runs. The state remains if the previous run+    -- ended in an exception (as we leave the files to help with debugging).+    cleanProject testdir++    (projectConfig, localPackages) <-+      rebuildProjectConfig verbosity+                           distDirLayout+                           cliConfig++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return (distDirLayout,+            cabalDirLayout,+            projectConfig,+            localPackages,+            buildSettings)++type PlanDetails = (ProjDetails,+                    ElaboratedInstallPlan,+                    ElaboratedSharedConfig)++planProject :: FilePath -> ProjectConfig -> IO PlanDetails+planProject testdir cliConfig = do++    projDetails@+      (distDirLayout,+       cabalDirLayout,+       projectConfig,+       localPackages,+       _buildSettings) <- configureProject testdir cliConfig++    (elaboratedPlan, _, elaboratedShared) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages++    return (projDetails,+            elaboratedPlan,+            elaboratedShared)++executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes)+executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings),+             elaboratedPlan,+             elaboratedShared) = do++    let targets :: Map.Map UnitId [ComponentTarget]+        targets =+          Map.fromList+            [ (unitid, [ComponentTarget cname WholeComponent])+            | ts <- Map.elems (availableTargets elaboratedPlan)+            , AvailableTarget {+                availableTargetStatus = TargetBuildable (unitid, cname) _+              } <- ts+            ]+        elaboratedPlan' = pruneInstallPlanToTargets+                            TargetActionBuild targets+                            elaboratedPlan++    pkgsBuildStatus <-+      rebuildTargetsDryRun distDirLayout elaboratedShared+                           elaboratedPlan'++    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                             pkgsBuildStatus elaboratedPlan'++    buildOutcomes <-+      rebuildTargets verbosity+                     distDirLayout+                     (cabalStoreDirLayout cabalDirLayout)+                     elaboratedPlan''+                     elaboratedShared+                     pkgsBuildStatus+                     -- Avoid trying to use act-as-setup mode:+                     buildSettings { buildSettingNumJobs = 1 }++    return (elaboratedPlan'', buildOutcomes)++cleanProject :: FilePath -> IO ()+cleanProject testdir = do+    alreadyExists <- doesDirectoryExist distDir+    when alreadyExists $ removeDirectoryRecursive distDir+  where+    projectRoot    = ProjectRootImplicit (basedir </> testdir)+    distDirLayout  = defaultDistDirLayout projectRoot Nothing+    distDir        = distDirectory distDirLayout+++verbosity :: Verbosity+verbosity = minBound --normal --verbose --maxBound --minBound++++-------------------------------------------+-- Tasty integration to adjust the config+--++withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree+withProjectConfig testtree =+    askOption $ \ghcPath ->+      testtree (mkProjectConfig ghcPath)++mkProjectConfig :: GhcPath -> ProjectConfig+mkProjectConfig (GhcPath ghcPath) =+    mempty {+      projectConfigShared = mempty {+        projectConfigHcPath = maybeToFlag ghcPath+      },+     projectConfigBuildOnly = mempty {+       projectConfigNumJobs = toFlag (Just 1)+     }+    }+  where+    maybeToFlag = maybe mempty toFlag+++data GhcPath = GhcPath (Maybe FilePath)+  deriving Typeable++instance IsOption GhcPath where+  defaultValue = GhcPath Nothing+  optionName   = Tagged "with-ghc"+  optionHelp   = Tagged "The ghc compiler to use"+  parseValue   = Just . GhcPath . Just++projectConfigOptionDescriptions :: [OptionDescription]+projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)]+++---------------------------------------+-- HUint style utils for this context+--++expectException :: Exception e => String -> IO a -> IO e+expectException expected action = do+    res <- try action+    case res of+      Left  e -> return e+      Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected++expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                         -> IO InstalledPackageInfo+expectPackagePreExisting plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.PreExisting pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult++expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                        -> IO ElaboratedConfiguredPackage+expectPackageConfigured plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Nothing)+                       -> return pkg+      (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult++expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                       -> IO (ElaboratedConfiguredPackage, BuildResult)+expectPackageInstalled plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Right result))+                       -> return (pkg, result)+      (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult++expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId+                    -> IO (ElaboratedConfiguredPackage, BuildFailure)+expectPackageFailed plan buildOutcomes pkgid = do+    planpkg <- expectPlanPackage plan pkgid+    case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of+      (InstallPlan.Configured pkg, Just (Left failure))+                       -> return (pkg, failure)+      (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult++unexpectedBuildResult :: String -> ElaboratedPlanPackage+                      -> Maybe (Either BuildFailure BuildResult) -> IO a+unexpectedBuildResult expected planpkg buildResult =+    throwIO $ HUnitFailure $+         "expected to find " ++ display (packageId planpkg) ++ " in the "+      ++ expected ++ " state, but it is actually in the " ++ actual ++ " state."+  where+    actual = case (buildResult, planpkg) of+      (Nothing, InstallPlan.PreExisting{})       -> "PreExisting"+      (Nothing, InstallPlan.Configured{})        -> "Configured"+      (Just (Right _), InstallPlan.Configured{}) -> "Installed"+      (Just (Left  _), InstallPlan.Configured{}) -> "Failed"+      _                                          -> "Impossible!"++expectPlanPackage :: ElaboratedInstallPlan -> PackageId+                  -> IO ElaboratedPlanPackage+expectPlanPackage plan pkgid =+    case [ pkg+         | pkg <- InstallPlan.toList plan+         , packageId pkg == pkgid ] of+      [pkg] -> return pkg+      []    -> throwIO $ HUnitFailure $+                   "expected to find " ++ display pkgid+                ++ " in the install plan but it's not there"+      _     -> throwIO $ HUnitFailure $+                   "expected to find only one instance of " ++ display pkgid+                ++ " in the install plan but there's several"++expectBuildFailed :: BuildFailure -> IO ()+expectBuildFailed (BuildFailure _ (BuildFailed _)) = return ()+expectBuildFailed (BuildFailure _ reason) =+    assertFailure $ "expected BuildFailed, got " ++ show reason++---------------------------------------+-- Other utils+--++-- | Allow altering a file during a test, but then restore it afterwards+--+withFileFinallyRestore :: FilePath -> IO a -> IO a+withFileFinallyRestore file action = do+    copyFile file backup+    action `finally` renameFile backup file+  where+    backup = file <.> "backup"
+ tests/IntegrationTests2/build/keep-going/cabal.project view
@@ -0,0 +1,1 @@+packages: p q
+ tests/IntegrationTests2/build/keep-going/p/P.hs view
@@ -0,0 +1,4 @@+module P where++p :: Int+p = this_is_not_expected_to_compile
+ tests/IntegrationTests2/build/keep-going/p/p.cabal view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,4 @@+module Q where++q :: Int+q = 42
+ tests/IntegrationTests2/build/keep-going/q/q.cabal view
@@ -0,0 +1,9 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: Q+  build-depends: base+
+ tests/IntegrationTests2/build/setup-custom1/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ tests/IntegrationTests2/build/setup-custom1/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain >> writeFile "marker" "ok"
+ tests/IntegrationTests2/build/setup-custom1/a.cabal view
@@ -0,0 +1,13 @@+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 view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ tests/IntegrationTests2/build/setup-custom2/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain >> writeFile "marker" "ok"
+ tests/IntegrationTests2/build/setup-custom2/a.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,4 @@+module A where++a :: Int+a = 42
+ tests/IntegrationTests2/build/setup-simple/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests2/build/setup-simple/a.cabal view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,4 @@+packages:++package foo+  ghc-location: bar
+ tests/IntegrationTests2/exception/build/Main.hs view
@@ -0,0 +1,1 @@+main = thisNameDoesNotExist
+ tests/IntegrationTests2/exception/build/a.cabal view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,1 @@+this is just here to ensure the source control creates the dir
+ tests/IntegrationTests2/exception/no-pkg2/cabal.project view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/regression/3324/cabal.project view
@@ -0,0 +1,1 @@+packages: p q
+ tests/IntegrationTests2/regression/3324/p/P.hs view
@@ -0,0 +1,4 @@+module P where++p :: Int+p = 42
+ tests/IntegrationTests2/regression/3324/p/p.cabal view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,6 @@+module Q where++import P++q :: Int+q = p
+ tests/IntegrationTests2/regression/3324/q/q.cabal view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/targets/all-disabled/p.cabal view
@@ -0,0 +1,23 @@+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 view
@@ -0,0 +1,1 @@+packages: ./ ./q/
+ tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal view
@@ -0,0 +1,15 @@+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 view
@@ -0,0 +1,10 @@+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 view
@@ -0,0 +1,1 @@+packages: q/
+ tests/IntegrationTests2/targets/complex/q/Q.hs view
+ tests/IntegrationTests2/targets/complex/q/q.cabal view
@@ -0,0 +1,22 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: Q+  build-depends: base, filepath++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 view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/targets/empty-pkg/p.cabal view
@@ -0,0 +1,5 @@+name: p+version: 0.1+build-type: Simple+cabal-version: >= 1.2+
+ tests/IntegrationTests2/targets/empty/cabal.project view
@@ -0,0 +1,1 @@+packages:
+ tests/IntegrationTests2/targets/empty/foo.hs view
+ tests/IntegrationTests2/targets/exes-disabled/cabal.project view
@@ -0,0 +1,1 @@+packages: p/ q/
+ tests/IntegrationTests2/targets/exes-disabled/p/p.cabal view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,9 @@+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/libs-disabled/cabal.project view
@@ -0,0 +1,1 @@+packages: p/ q/
+ tests/IntegrationTests2/targets/libs-disabled/p/p.cabal view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/targets/multiple-exes/p.cabal view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,1 @@+packages: p/ q/
+ tests/IntegrationTests2/targets/multiple-libs/p/p.cabal view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/targets/multiple-tests/p.cabal view
@@ -0,0 +1,14 @@+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 view
+ tests/IntegrationTests2/targets/simple/cabal.project view
@@ -0,0 +1,1 @@+packages: ./ q/
+ tests/IntegrationTests2/targets/simple/p.cabal view
@@ -0,0 +1,12 @@+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
+ tests/IntegrationTests2/targets/simple/q/QQ.hs view
+ tests/IntegrationTests2/targets/simple/q/q.cabal view
@@ -0,0 +1,12 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: QQ+  build-depends: base++executable qexe+  main-is: Main.hs+  other-modules: QMain
+ tests/IntegrationTests2/targets/test-only/p.cabal view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,1 @@+packages: ./ ./q/
+ tests/IntegrationTests2/targets/tests-disabled/p.cabal view
@@ -0,0 +1,15 @@+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 view
@@ -0,0 +1,10 @@+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 view
@@ -0,0 +1,1 @@+packages: ./
+ tests/IntegrationTests2/targets/variety/p.cabal view
@@ -0,0 +1,27 @@+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+
+ tests/MemoryUsageTests.hs view
@@ -0,0 +1,15 @@+module MemoryUsageTests where++import Test.Tasty++import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage++tests :: TestTree+tests =+  testGroup "Memory Usage"+  [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage"+        UnitTests.Distribution.Solver.Modular.MemoryUsage.tests+  ]++main :: IO ()+main = defaultMain tests
+ tests/SolverQuickCheck.hs view
@@ -0,0 +1,16 @@+module SolverQuickCheck where++import Test.Tasty++import qualified UnitTests.Distribution.Solver.Modular.QuickCheck+++tests :: TestTree+tests =+  testGroup "Solver QuickCheck"+  [ testGroup "UnitTests.Distribution.Solver.Modular.QuickCheck"+        UnitTests.Distribution.Solver.Modular.QuickCheck.tests+  ]++main :: IO ()+main = defaultMain tests
tests/UnitTests.hs view
@@ -1,31 +1,31 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Main-       where+module UnitTests where  import Test.Tasty -import Control.Monad-import Data.Time.Clock-import System.FilePath- import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Client.Compat.Time+import Distribution.Compat.Time -import qualified UnitTests.Distribution.Client.Compat.Time-import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ-import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver+import qualified UnitTests.Distribution.Solver.Modular.PSQ+import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ+import qualified UnitTests.Distribution.Solver.Modular.Solver+import qualified UnitTests.Distribution.Solver.Modular.RetryLog import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Sandbox import qualified UnitTests.Distribution.Client.Sandbox.Timestamp+import qualified UnitTests.Distribution.Client.Store import qualified UnitTests.Distribution.Client.Tar import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.ProjectConfig+import qualified UnitTests.Distribution.Client.JobControl+import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp+import qualified UnitTests.Distribution.Client.InstallPlan  import UnitTests.Options @@ -38,12 +38,14 @@                     else mtimeChangeCalibrated   in   testGroup "Unit Tests"-  [ testGroup "UnitTests.Distribution.Client.Compat.Time" $-        UnitTests.Distribution.Client.Compat.Time.tests mtimeChange-  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"-        UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests-  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"-        UnitTests.Distribution.Client.Dependency.Modular.Solver.tests+  [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ"+        UnitTests.Distribution.Solver.Modular.PSQ.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"+        UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.Solver"+        UnitTests.Distribution.Solver.Modular.Solver.tests+  , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"+        UnitTests.Distribution.Solver.Modular.RetryLog.tests   , testGroup "UnitTests.Distribution.Client.FileMonitor" $         UnitTests.Distribution.Client.FileMonitor.tests mtimeChange   , testGroup "UnitTests.Distribution.Client.Glob"@@ -54,6 +56,8 @@        UnitTests.Distribution.Client.Sandbox.tests   , testGroup "Distribution.Client.Sandbox.Timestamp"        UnitTests.Distribution.Client.Sandbox.Timestamp.tests+  , testGroup "Distribution.Client.Store"+       UnitTests.Distribution.Client.Store.tests   , testGroup "Distribution.Client.Tar"        UnitTests.Distribution.Client.Tar.tests   , testGroup "Distribution.Client.Targets"@@ -62,45 +66,25 @@        UnitTests.Distribution.Client.UserConfig.tests   , testGroup "UnitTests.Distribution.Client.ProjectConfig"        UnitTests.Distribution.Client.ProjectConfig.tests+  , testGroup "UnitTests.Distribution.Client.JobControl"+       UnitTests.Distribution.Client.JobControl.tests+  , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"+       UnitTests.Distribution.Client.IndexUtils.Timestamp.tests+  , testGroup "UnitTests.Distribution.Client.InstallPlan"+       UnitTests.Distribution.Client.InstallPlan.tests   ]  main :: IO () main = do-  mtimeChangeDelay <- calibrateMtimeChangeDelay+  (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay+  let toMillis :: Int -> Double+      toMillis x = fromIntegral x / 1000.0+  notice normal $ "File modification time resolution calibration completed, "+    ++ "maximum delay observed: "+    ++ (show . toMillis $ mtimeChange ) ++ " ms. "+    ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')+    ++ " for test runs."   defaultMainWithIngredients          (includingOptions extraOptions : defaultIngredients)-         (tests mtimeChangeDelay)---- Based on code written by Neill Mitchell for Shake. See--- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller--- than 10 ms, but never larger than 1 second.-calibrateMtimeChangeDelay :: IO Int-calibrateMtimeChangeDelay = do-  withTempDirectory silent "." "calibration-" $ \dir -> do-    let fileName = dir </> "probe"-    mtimes <- forM [1..25] $ \(i::Int) -> time $ do-      writeFile fileName $ show i-      t0 <- getModTime fileName-      let spin j = do-            writeFile fileName $ show (i,j)-            t1 <- getModTime fileName-            unless (t0 < t1) (spin $ j + 1)-      spin (0::Int)-    let mtimeChange  = maximum mtimes-        mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2-    notice normal $ "File modification time resolution calibration completed, "-      ++ "maximum delay observed: "-      ++ (show . toMillis $ mtimeChange ) ++ " ms. "-      ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')-      ++ " for test runs."-    return mtimeChange'-  where-    toMillis :: Int -> Double-    toMillis x = fromIntegral x / 1000.0+         (tests mtimeChange') -    time :: IO () -> IO Int-    time act = do-      t0 <- getCurrentTime-      act-      t1 <- getCurrentTime-      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
tests/UnitTests/Distribution/Client/ArbitraryInstances.hs view
@@ -21,6 +21,7 @@ import Control.Monad  import Distribution.Version+import Distribution.Types.Dependency import Distribution.Package import Distribution.System import Distribution.Verbosity@@ -30,6 +31,8 @@  import Distribution.Utils.NubList +import Distribution.Client.IndexUtils.Timestamp+ import Test.QuickCheck  @@ -67,7 +70,6 @@ arbitraryShortToken :: Gen String arbitraryShortToken = getShortToken <$> arbitrary -#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary Version where   arbitrary = do     branch <- shortListOf1 4 $@@ -75,14 +77,11 @@                           ,(3, return 1)                           ,(2, return 2)                           ,(1, return 3)]-    return (Version branch []) -- deliberate []+    return (mkVersion branch)     where -  shrink (Version branch []) =-    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]-  shrink (Version branch _tags) =-    [ Version branch [] ]-#endif+  shrink ver = [ mkVersion branch' | branch' <- shrink (versionNumbers ver)+                                   , not (null branch') ]  instance Arbitrary VersionRange where   arbitrary = canonicaliseVersionRange <$> sized verRangeExp@@ -113,7 +112,7 @@       canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals  instance Arbitrary PackageName where-    arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent+    arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent       where         nameComponent = shortListOf1 5 (elements packageChars)                         `suchThat` (not . all isDigit)@@ -172,3 +171,10 @@     arbitrary = NoShrink <$> arbitrary     shrink _  = [] +instance Arbitrary Timestamp where+    arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary++instance Arbitrary IndexState where+    arbitrary = frequency [ (1, pure IndexStateHead)+                          , (50, IndexStateTime <$> arbitrary)+                          ]
− tests/UnitTests/Distribution/Client/Compat/Time.hs 
@@ -1,49 +0,0 @@-module UnitTests.Distribution.Client.Compat.Time (tests) where--import Control.Concurrent (threadDelay)-import System.FilePath--import Distribution.Simple.Utils (withTempDirectory)-import Distribution.Verbosity--import Distribution.Client.Compat.Time--import Test.Tasty-import Test.Tasty.HUnit--tests :: Int -> [TestTree]-tests mtimeChange =-  [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange-  , testCase "getCurTime works as expected"         $ getCurTimeTest mtimeChange-  ]--getModTimeTest :: Int -> Assertion-getModTimeTest mtimeChange =-  withTempDirectory silent "." "getmodtime-" $ \dir -> do-    let fileName = dir </> "foo"-    writeFile fileName "bar"-    t0 <- getModTime fileName-    threadDelay mtimeChange-    writeFile fileName "baz"-    t1 <- getModTime fileName-    assertBool "expected different file mtimes" (t1 > t0)---getCurTimeTest :: Int -> Assertion-getCurTimeTest mtimeChange =-  withTempDirectory silent "." "getmodtime-" $ \dir -> do-    let fileName = dir </> "foo"-    writeFile fileName "bar"-    t0 <- getModTime fileName-    threadDelay mtimeChange-    t1 <- getCurTime-    assertBool("expected file mtime (" ++ show t0-               ++ ") to be earlier than current time (" ++ show t1 ++ ")")-      (t0 < t1)--    threadDelay mtimeChange-    writeFile fileName "baz"-    t2 <- getModTime fileName-    assertBool ("expected current time (" ++ show t1-                ++ ") to be earlier than file mtime (" ++ show t2 ++ ")")-      (t1 < t2)
− tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs 
@@ -1,418 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- | DSL for testing the modular solver-module UnitTests.Distribution.Client.Dependency.Modular.DSL (-    ExampleDependency(..)-  , Dependencies(..)-  , ExTest(..)-  , ExPreference(..)-  , ExampleDb-  , ExampleVersionRange-  , ExamplePkgVersion-  , exAv-  , exInst-  , exFlag-  , exResolve-  , extractInstallPlan-  , withSetupDeps-  , withTest-  , withTests-  ) where---- base-import Data.Either (partitionEithers)-import Data.Maybe (catMaybes)-import Data.List (nub)-import Data.Monoid-import Data.Version-import qualified Data.Map as Map---- Cabal-import qualified Distribution.Compiler             as C-import qualified Distribution.InstalledPackageInfo as C-import qualified Distribution.Package              as C-  hiding (HasUnitId(..))-import qualified Distribution.PackageDescription   as C-import qualified Distribution.Simple.PackageIndex  as C.PackageIndex-import qualified Distribution.System               as C-import qualified Distribution.Version              as C-import Language.Haskell.Extension (Extension(..), Language)---- cabal-install-import Distribution.Client.ComponentDeps (ComponentDeps)-import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-import Distribution.Client.Types-import qualified Distribution.Client.InstallPlan   as CI.InstallPlan-import qualified Distribution.Client.PackageIndex  as CI.PackageIndex-import qualified Distribution.Client.PkgConfigDb   as PC-import qualified Distribution.Client.ComponentDeps as CD--{--------------------------------------------------------------------------------  Example package database DSL--  In order to be able to set simple examples up quickly, we define a very-  simple version of the package database here explicitly designed for use in-  tests.--  The design of `ExampleDb` takes the perspective of the solver, not the-  perspective of the package DB. This makes it easier to set up tests for-  various parts of the solver, but makes the mapping somewhat awkward,  because-  it means we first map from "solver perspective" `ExampleDb` to the package-  database format, and then the modular solver internally in `IndexConversion`-  maps this back to the solver specific data structures.--  IMPLEMENTATION NOTES-  ----------------------  TODO: Perhaps these should be made comments of the corresponding data type-  definitions. For now these are just my own conclusions and may be wrong.--  * The difference between `GenericPackageDescription` and `PackageDescription`-    is that `PackageDescription` describes a particular _configuration_ of a-    package (for instance, see documentation for `checkPackage`). A-    `GenericPackageDescription` can be turned into a `PackageDescription` in-    two ways:--      a. `finalizePackageDescription` does the proper translation, by taking-         into account the platform, available dependencies, etc. and picks a-         flag assignment (or gives an error if no flag assignment can be found)-      b. `flattenPackageDescription` ignores flag assignment and just joins all-         components together.--    The slightly odd thing is that a `GenericPackageDescription` contains a-    `PackageDescription` as a field; both of the above functions do the same-    thing: they take the embedded `PackageDescription` as a basis for the result-    value, but override `library`, `executables`, `testSuites`, `benchmarks`-    and `buildDepends`.-  * The `condTreeComponents` fields of a `CondTree` is a list of triples-    `(condition, then-branch, else-branch)`, where the `else-branch` is-    optional.--------------------------------------------------------------------------------}--type ExamplePkgName    = String-type ExamplePkgVersion = Int-type ExamplePkgHash    = String  -- for example "installed" packages-type ExampleFlagName   = String-type ExampleTestName   = String-type ExampleVersionRange = C.VersionRange-data Dependencies = NotBuildable | Buildable [ExampleDependency]--data ExampleDependency =-    -- | Simple dependency on any version-    ExAny ExamplePkgName--    -- | Simple dependency on a fixed version-  | ExFix ExamplePkgName ExamplePkgVersion--    -- | Dependencies indexed by a flag-  | ExFlag ExampleFlagName Dependencies Dependencies--    -- | Dependency on a language extension-  | ExExt Extension--    -- | Dependency on a language version-  | ExLang Language--    -- | Dependency on a pkg-config package-  | ExPkg (ExamplePkgName, ExamplePkgVersion)--data ExTest = ExTest ExampleTestName [ExampleDependency]--exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]-       -> ExampleDependency-exFlag n t e = ExFlag n (Buildable t) (Buildable e)--data ExPreference = ExPref String ExampleVersionRange--data ExampleAvailable = ExAv {-    exAvName    :: ExamplePkgName-  , exAvVersion :: ExamplePkgVersion-  , exAvDeps    :: ComponentDeps [ExampleDependency]-  }--exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]-     -> ExampleAvailable-exAv n v ds = ExAv { exAvName = n, exAvVersion = v-                   , exAvDeps = CD.fromLibraryDeps ds }--withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable-withSetupDeps ex setupDeps = ex {-      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps-    }--withTest :: ExampleAvailable -> ExTest -> ExampleAvailable-withTest ex test = withTests ex [test]--withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable-withTests ex tests =-  let testCDs = CD.fromList [(CD.ComponentTest name, deps)-                            | ExTest name deps <- tests]-  in ex { exAvDeps = exAvDeps ex <> testCDs }--data ExampleInstalled = ExInst {-    exInstName         :: ExamplePkgName-  , exInstVersion      :: ExamplePkgVersion-  , exInstHash         :: ExamplePkgHash-  , exInstBuildAgainst :: [ExampleInstalled]-  }--exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash-       -> [ExampleInstalled] -> ExampleInstalled-exInst = ExInst--type ExampleDb = [Either ExampleInstalled ExampleAvailable]--type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a--exDbPkgs :: ExampleDb -> [ExamplePkgName]-exDbPkgs = map (either exInstName exAvName)--exAvSrcPkg :: ExampleAvailable -> SourcePackage-exAvSrcPkg ex =-    let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex))-        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]-    in SourcePackage {-           packageInfoId        = exAvPkgId ex-         , packageSource        = LocalTarballPackage "<<path>>"-         , packageDescrOverride = Nothing-         , packageDescription   = C.GenericPackageDescription {-               C.packageDescription = C.emptyPackageDescription {-                   C.package        = exAvPkgId ex-                 , C.library        = error "not yet configured: library"-                 , C.executables    = error "not yet configured: executables"-                 , C.testSuites     = error "not yet configured: testSuites"-                 , C.benchmarks     = error "not yet configured: benchmarks"-                 , C.buildDepends   = error "not yet configured: buildDepends"-                 , C.setupBuildInfo = Just C.SetupBuildInfo {-                       C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex)),-                       C.defaultSetupDepends = False-                     }-                 }-             , C.genPackageFlags = nub $ concatMap extractFlags $-                                   CD.libraryDeps (exAvDeps ex) ++ concatMap snd testSuites-             , C.condLibrary     = Just $ mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs)-                                                     disableLib-                                                     (Buildable libraryDeps)-             , C.condExecutables = []-             , C.condTestSuites  =-                 let mkTree = mkCondTree mempty disableTest . Buildable-                 in map (\(t, deps) -> (t, mkTree deps)) testSuites-             , C.condBenchmarks  = []-             }-         }-  where-    -- Split the set of dependencies into the set of dependencies of the library,-    -- the dependencies of the test suites and extensions.-    splitTopLevel :: [ExampleDependency]-                  -> ( [ExampleDependency]-                     , [Extension]-                     , Maybe Language-                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config-                     )-    splitTopLevel [] =-        ([], [], Nothing, [])-    splitTopLevel (ExExt ext:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (other, ext:exts, lang, pcpkgs)-    splitTopLevel (ExLang lang:deps) =-        case splitTopLevel deps of-            (other, exts, Nothing, pcpkgs) -> (other, exts, Just lang, pcpkgs)-            _ -> error "Only 1 Language dependency is supported"-    splitTopLevel (ExPkg pkg:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (other, exts, lang, pkg:pcpkgs)-    splitTopLevel (dep:deps) =-      let (other, exts, lang, pcpkgs) = splitTopLevel deps-      in (dep:other, exts, lang, pcpkgs)--    -- Extract the total set of flags used-    extractFlags :: ExampleDependency -> [C.Flag]-    extractFlags (ExAny _)      = []-    extractFlags (ExFix _ _)    = []-    extractFlags (ExFlag f a b) = C.MkFlag {-                                      C.flagName        = C.FlagName f-                                    , C.flagDescription = ""-                                    , C.flagDefault     = True-                                    , C.flagManual      = False-                                    }-                                : concatMap extractFlags (deps a ++ deps b)-      where-        deps :: Dependencies -> [ExampleDependency]-        deps NotBuildable = []-        deps (Buildable ds) = ds-    extractFlags (ExExt _)      = []-    extractFlags (ExLang _)     = []-    extractFlags (ExPkg _)      = []--    mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a-    mkCondTree x dontBuild NotBuildable =-      C.CondNode {-             C.condTreeData        = dontBuild x-           , C.condTreeConstraints = []-           , C.condTreeComponents  = []-           }-    mkCondTree x dontBuild (Buildable deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in C.CondNode {-             C.condTreeData        = x -- Necessary for language extensions-           , C.condTreeConstraints = map mkDirect directDeps-           , C.condTreeComponents  = map (mkFlagged dontBuild) flaggedDeps-           }--    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency-    mkDirect (dep, Nothing) = C.Dependency (C.PackageName dep) C.anyVersion-    mkDirect (dep, Just n)  = C.Dependency (C.PackageName dep) (C.thisVersion v)-      where-        v = Version [n, 0, 0] []--    mkFlagged :: Monoid a-              => (a -> a)-              -> (ExampleFlagName, Dependencies, Dependencies)-              -> (C.Condition C.ConfVar-                 , DependencyTree a, Maybe (DependencyTree a))-    mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))-                                    , mkCondTree mempty dontBuild a-                                    , Just (mkCondTree mempty dontBuild b)-                                    )--    -- Split a set of dependencies into direct dependencies and flagged-    -- dependencies. A direct dependency is a tuple of the name of package and-    -- maybe its version (no version means any version) meant to be converted-    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is-    -- the set of dependencies guarded by a flag.-    ---    -- TODO: Take care of flagged language extensions and language flavours.-    splitDeps :: [ExampleDependency]-              -> ( [(ExamplePkgName, Maybe Int)]-                 , [(ExampleFlagName, Dependencies, Dependencies)]-                 )-    splitDeps [] =-      ([], [])-    splitDeps (ExAny p:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in ((p, Nothing):directDeps, flaggedDeps)-    splitDeps (ExFix p v:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in ((p, Just v):directDeps, flaggedDeps)-    splitDeps (ExFlag f a b:deps) =-      let (directDeps, flaggedDeps) = splitDeps deps-      in (directDeps, (f, a, b):flaggedDeps)-    splitDeps (_:deps) = splitDeps deps--    -- Currently we only support simple setup dependencies-    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]-    mkSetupDeps deps =-      let (directDeps, []) = splitDeps deps in map mkDirect directDeps--    -- A 'C.Library' with just the given extensions in its 'BuildInfo'-    extsLib :: [Extension] -> C.Library-    extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }--    -- A 'C.Library' with just the given extensions in its 'BuildInfo'-    langLib :: Maybe Language -> C.Library-    langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }-    langLib _ = mempty--    disableLib :: C.Library -> C.Library-    disableLib lib =-        lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}--    disableTest :: C.TestSuite -> C.TestSuite-    disableTest test =-        test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}--    -- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo'-    pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library-    pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } }--exAvPkgId :: ExampleAvailable -> C.PackageIdentifier-exAvPkgId ex = C.PackageIdentifier {-      pkgName    = C.PackageName (exAvName ex)-    , pkgVersion = Version [exAvVersion ex, 0, 0] []-    }--exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo-exInstInfo ex = C.emptyInstalledPackageInfo {-      C.installedUnitId    = C.mkUnitId (exInstHash ex)-    , C.sourcePackageId    = exInstPkgId ex-    , C.depends            = map (C.mkUnitId . exInstHash)-                                 (exInstBuildAgainst ex)-    }--exInstPkgId :: ExampleInstalled -> C.PackageIdentifier-exInstPkgId ex = C.PackageIdentifier {-      pkgName    = C.PackageName (exInstName ex)-    , pkgVersion = Version [exInstVersion ex, 0, 0] []-    }--exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage-exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg--exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex-exInstIdx = C.PackageIndex.fromList . map exInstInfo--exResolve :: ExampleDb-          -- List of extensions supported by the compiler, or Nothing if unknown.-          -> Maybe [Extension]-          -- List of languages supported by the compiler, or Nothing if unknown.-          -> Maybe [Language]-          -> PC.PkgConfigDb-          -> [ExamplePkgName]-          -> Bool-          -> [ExPreference]-          -> ([String], Either String CI.InstallPlan.InstallPlan)-exResolve db exts langs pkgConfigDb targets indepGoals prefs = runProgress $-    resolveDependencies C.buildPlatform-                        compiler pkgConfigDb-                        Modular-                        params-  where-    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag-    compiler = defaultCompiler { C.compilerInfoExtensions = exts-                               , C.compilerInfoLanguages  = langs-                               }-    (inst, avai) = partitionEithers db-    instIdx      = exInstIdx inst-    avaiIdx      = SourcePackageDb {-                       packageIndex       = exAvIdx avai-                     , packagePreferences = Map.empty-                     }-    enableTests  = fmap (\p -> PackageConstraintStanzas-                              (C.PackageName p) [TestStanzas])-                       (exDbPkgs db)-    targets'     = fmap (\p -> NamedPackage (C.PackageName p) []) targets-    params       =   addPreferences (fmap toPref prefs)-                   $ addConstraints (fmap toLpc enableTests)-                   $ (standardInstallPolicy instIdx avaiIdx targets') {-                     depResolverIndependentGoals = indepGoals-                     }-    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown-    toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v--extractInstallPlan :: CI.InstallPlan.InstallPlan-                   -> [(ExamplePkgName, ExamplePkgVersion)]-extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList-  where-    confPkg :: CI.InstallPlan.PlanPackage -> Maybe (String, Int)-    confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg-    confPkg _                               = Nothing--    srcPkg :: ConfiguredPackage -> (String, Int)-    srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =-      let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =-            packageInfoId pkg-      in (p, n)--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}---- | Run Progress computation------ Like `runLog`, but for the more general `Progress` type.-runProgress :: Progress step e a -> ([step], Either e a)-runProgress = go-  where-    go (Step s p) = let (ss, result) = go p in (s:ss, result)-    go (Fail e)   = ([], Left e)-    go (Done a)   = ([], Right a)
− tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs 
@@ -1,22 +0,0 @@-module UnitTests.Distribution.Client.Dependency.Modular.PSQ (-  tests-  ) where--import Distribution.Client.Dependency.Modular.PSQ--import Test.Tasty-import Test.Tasty.QuickCheck--tests :: [TestTree]-tests = [ testProperty "splitsAltImplementation" splitsTest-        ]---- | Original splits implementation-splits' :: PSQ k a -> PSQ k (a, PSQ k a)-splits' xs =-  casePSQ xs-    (PSQ [])-    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))--splitsTest :: [(Int, Int)] -> Bool-splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)
− tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs 
@@ -1,805 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests)-       where---- base-import Control.Monad-import Data.List (isInfixOf)--import qualified Data.Version         as V-import qualified Distribution.Version as V---- test-framework-import Test.Tasty as TF-import Test.Tasty.HUnit (testCase, assertEqual, assertBool)---- Cabal-import Language.Haskell.Extension ( Extension(..)-                                  , KnownExtension(..), Language(..))---- cabal-install-import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)-import UnitTests.Distribution.Client.Dependency.Modular.DSL-import UnitTests.Options--tests :: [TF.TestTree]-tests = [-      testGroup "Simple dependencies" [-          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (SolverSuccess [])-        , runTest $         mkTest db1 "installLatest"      ["B"]      (SolverSuccess [("B", 2)])-        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (SolverSuccess [("B", 1), ("C", 1)])-        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (SolverSuccess [("B", 2), ("D", 1)])-        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] anySolverFailure-        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (SolverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (SolverSuccess [("B", 1), ("C", 1), ("E", 1)])-        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (SolverSuccess [("B", 2), ("D", 1), ("E", 1)])-        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (SolverSuccess [("B", 1), ("E", 1), ("F", 1)])-        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (SolverSuccess [("B", 2), ("E", 1), ("G", 1)])-        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] anySolverFailure-        , runTest $         mkTest db21 "unknownPackage1"   ["A"]      (SolverSuccess [("A", 1), ("B", 1)])-        , runTest $         mkTest db22 "unknownPackage2"   ["A"]      (SolverFailure (isInfixOf "unknown package: C"))-        ]-    , testGroup "Flagged dependencies" [-          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (SolverSuccess [("A", 1), ("B", 1), ("C", 1)])-        , runTest $         mkTest db3 "forceFlagOff" ["D"]      (SolverSuccess [("A", 2), ("B", 1), ("D", 1)])-        , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] anySolverFailure-        , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] anySolverFailure-        , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])-        ]-    , testGroup "Stanzas" [-          runTest $         mkTest db5 "simpleTest1" ["C"]      (SolverSuccess [("A", 2), ("C", 1)])-        , runTest $         mkTest db5 "simpleTest2" ["D"]      anySolverFailure-        , runTest $         mkTest db5 "simpleTest3" ["E"]      (SolverSuccess [("A", 1), ("E", 1)])-        , runTest $         mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO-        , runTest $         mkTest db5 "simpleTest5" ["G"]      (SolverSuccess [("A", 2), ("G", 1)])-        , runTest $         mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure-        , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (SolverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])-        , runTest $         mkTest db6 "depsWithTests1" ["C"]      (SolverSuccess [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])-        ]-    , testGroup "Setup dependencies" [-          runTest $         mkTest db7  "setupDeps1" ["B"] (SolverSuccess [("A", 2), ("B", 1)])-        , runTest $         mkTest db7  "setupDeps2" ["C"] (SolverSuccess [("A", 2), ("C", 1)])-        , runTest $         mkTest db7  "setupDeps3" ["D"] (SolverSuccess [("A", 1), ("D", 1)])-        , runTest $         mkTest db7  "setupDeps4" ["E"] (SolverSuccess [("A", 1), ("A", 2), ("E", 1)])-        , runTest $         mkTest db7  "setupDeps5" ["F"] (SolverSuccess [("A", 1), ("A", 2), ("F", 1)])-        , runTest $         mkTest db8  "setupDeps6" ["C", "D"] (SolverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])-        , runTest $         mkTest db9  "setupDeps7" ["F", "G"] (SolverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])-        , runTest $         mkTest db10 "setupDeps8" ["C"] (SolverSuccess [("C", 1)])-        , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])-        ]-    , testGroup "Base shim" [-          runTest $ mkTest db11 "baseShim1" ["A"] (SolverSuccess [("A", 1)])-        , runTest $ mkTest db12 "baseShim2" ["A"] (SolverSuccess [("A", 1)])-        , runTest $ mkTest db12 "baseShim3" ["B"] (SolverSuccess [("B", 1)])-        , runTest $ mkTest db12 "baseShim4" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure-        , runTest $ mkTest db12 "baseShim6" ["E"] (SolverSuccess [("E", 1), ("syb", 2)])-        ]-    , testGroup "Cycles" [-          runTest $ mkTest db14 "simpleCycle1"          ["A"]      anySolverFailure-        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] anySolverFailure-        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (SolverSuccess [("C", 1), ("E", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      anySolverFailure-        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      anySolverFailure-        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (SolverSuccess [("C", 2), ("D", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (SolverSuccess [("D", 1)])-        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (SolverSuccess [("C", 2), ("D", 1), ("E", 1)])-        ]-    , testGroup "Extensions" [-          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure-        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure-        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (SolverSuccess [("A",1)])-        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (SolverSuccess [("A",1),("B",1), ("C",1)])-        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure-        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure-        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (SolverSuccess [("A",1),("B",1),("C",1),("E",1)])-        ]-    , testGroup "Languages" [-          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure-        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (SolverSuccess [("A",1)])-        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure-        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (SolverSuccess [("A",1),("B",1),("C",1)])-        ]--     , testGroup "Soft Constraints" [-          runTest $ soft [ ExPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (SolverSuccess [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (SolverSuccess [("A", 2)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2-                         , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (SolverSuccess [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (SolverSuccess [("A", 1)])-        , runTest $ soft [ ExPref "A" $ mkvrThis 1-                         , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (SolverSuccess [("A", 2)])-        , runTest $ soft [ ExPref "A" $ mkvrThis 1-                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (SolverSuccess [("A", 1)])-        ]-     , testGroup "Buildable Field" [-          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")-        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))-        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))-        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (SolverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])-        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (SolverSuccess [("A", 1), ("B", 2)])-         ]-    , testGroup "Pkg-config dependencies" [-          runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure-        , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure-        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)])-        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (SolverSuccess [("A", 1), ("B", 2), ("C", 1)])-        ]-    , testGroup "Independent goals" [-          runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])-        , runTest $ indep $ mkTest db17 "indepGoals2" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])-        , runTest $ indep $ mkTest db19 "indepGoals3" ["D", "E", "F"] anySolverFailure -- The target order is important.-        , runTest $ indep $ mkTest db20 "indepGoals4" ["C", "A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])-        , runTest $ indep $ mkTest db23 "indepGoals5" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)])-        , runTest $ indep $ mkTest db24 "indepGoals6" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)])-        ]-    ]-  where-    indep test      = test { testIndepGoals = True }-    soft prefs test = test { testSoftConstraints = prefs }-    mkvrThis        = V.thisVersion . makeV-    mkvrOrEarlier   = V.orEarlierVersion . makeV-    makeV v         = V.Version [v,0,0] []--{--------------------------------------------------------------------------------  Solver tests--------------------------------------------------------------------------------}--data SolverTest = SolverTest {-    testLabel          :: String-  , testTargets        :: [String]-  , testResult         :: SolverResult-  , testIndepGoals     :: Bool-  , testSoftConstraints :: [ExPreference]-  , testDb             :: ExampleDb-  , testSupportedExts  :: Maybe [Extension]-  , testSupportedLangs :: Maybe [Language]-  , testPkgConfigDb    :: PkgConfigDb-  }---- | Result of a solver test.-data SolverResult =-    SolverSuccess [(String, Int)]  -- ^ succeeds with given plan-  | SolverFailure (String -> Bool) -- ^ fails, and the error message satisfies the predicate---- | Can be used for test cases where we just want to verify that--- they fail, but do not care about the error message.-anySolverFailure :: SolverResult-anySolverFailure = SolverFailure (const True)--mkTest :: ExampleDb-       -> String-       -> [String]-       -> SolverResult-       -> SolverTest-mkTest = mkTestExtLangPC Nothing Nothing []--mkTestExts :: [Extension]-           -> ExampleDb-           -> String-           -> [String]-           -> SolverResult-           -> SolverTest-mkTestExts exts = mkTestExtLangPC (Just exts) Nothing []--mkTestLangs :: [Language]-            -> ExampleDb-            -> String-            -> [String]-            -> SolverResult-            -> SolverTest-mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) []--mkTestPCDepends :: [(String, String)]-                -> ExampleDb-                -> String-                -> [String]-                -> SolverResult-                -> SolverTest-mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb--mkTestExtLangPC :: Maybe [Extension]-                -> Maybe [Language]-                -> [(String, String)]-                -> ExampleDb-                -> String-                -> [String]-                -> SolverResult-                -> SolverTest-mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {-    testLabel          = label-  , testTargets        = targets-  , testResult         = result-  , testIndepGoals     = False-  , testSoftConstraints = []-  , testDb             = db-  , testSupportedExts  = exts-  , testSupportedLangs = langs-  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb-  }--runTest :: SolverTest -> TF.TestTree-runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->-    testCase testLabel $ do-      let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs-                            testPkgConfigDb testTargets testIndepGoals testSoftConstraints-      when showSolverLog $ mapM_ putStrLn _msgs-      case result of-        Left  err  -> assertBool ("Unexpected error:\n" ++ err) (check testResult err)-        Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))-  where-    toMaybe :: SolverResult -> Maybe ([(String, Int)])-    toMaybe (SolverSuccess plan) = Just plan-    toMaybe (SolverFailure _   ) = Nothing--    check :: SolverResult -> (String -> Bool)-    check (SolverFailure f) = f-    check _                 = const False--{--------------------------------------------------------------------------------  Specific example database for the tests--------------------------------------------------------------------------------}--db1 :: ExampleDb-db1 =-    let a = exInst "A" 1 "A-1" []-    in [ Left a-       , Right $ exAv "B" 1 [ExAny "A"]-       , Right $ exAv "B" 2 [ExAny "A"]-       , Right $ exAv "C" 1 [ExFix "B" 1]-       , Right $ exAv "D" 1 [ExFix "B" 2]-       , Right $ exAv "E" 1 [ExAny "B"]-       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]-       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]-       , Right $ exAv "Z" 1 []-       ]---- In this example, we _can_ install C and D as independent goals, but we have--- to pick two diferent versions for B (arbitrarily)-db2 :: ExampleDb-db2 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "B" 2 [ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]-  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]-  ]--db3 :: ExampleDb-db3 = [-     Right $ exAv "A" 1 []-   , Right $ exAv "A" 2 []-   , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]-   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]-   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]-   ]---- | Like db3, but the flag picks a different package rather than a--- different package version------ In db3 we cannot install C and D as independent goals because:------ * The multiple instance restriction says C and D _must_ share B--- * Since C relies on A-1, C needs B to be compiled with flagB on--- * Since D relies on A-2, D needs B to be compiled with flagB off--- * Hence C and D have incompatible requirements on B's flags.------ However, _even_ if we don't check explicitly that we pick the same flag--- assignment for 0.B and 1.B, we will still detect the problem because--- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to--- 1.A and therefore we cannot link 0.B to 1.B.------ In db4 the situation however is trickier. We again cannot install--- packages C and D as independent goals because:------ * As above, the multiple instance restriction says that C and D _must_ share B--- * Since C relies on Ax-2, it requires B to be compiled with flagB off--- * Since D relies on Ay-2, it requires B to be compiled with flagB on--- * Hence C and D have incompatible requirements on B's flags.------ But now this requirement is more indirect. If we only check dependencies--- we don't see the problem:------ * We link 0.B to 1.B--- * 0.B relies on Ay-1--- * 1.B relies on Ax-1------ We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since--- we only ever assign to one of these, these constraints are never broken.-db4 :: ExampleDb-db4 = [-     Right $ exAv "Ax" 1 []-   , Right $ exAv "Ax" 2 []-   , Right $ exAv "Ay" 1 []-   , Right $ exAv "Ay" 2 []-   , Right $ exAv "B"  1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]-   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]-   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]-   ]---- | Some tests involving testsuites------ Note that in this test framework test suites are always enabled; if you--- want to test without test suites just set up a test database without--- test suites.------ * C depends on A (through its test suite)--- * D depends on B-2 (through its test suite), but B-2 is unavailable--- * E depends on A-1 directly and on A through its test suite. We prefer---     to use A-1 for the test suite in this case.--- * F depends on A-1 directly and on A-2 through its test suite. In this---     case we currently fail to install F, although strictly speaking---     test suites should be considered independent goals.--- * G is like E, but for version A-2. This means that if we cannot install---     E and G together, unless we regard them as independent goals.-db5 :: ExampleDb-db5 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 []-  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]-  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]-  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]-  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]-  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]-  ]---- Now the _dependencies_ have test suites------ * Installing C is a simple example. C wants version 1 of A, but depends on---   B, and B's testsuite depends on an any version of A. In this case we prefer---   to link (if we don't regard test suites as independent goals then of course---   linking here doesn't even come into it).--- * Installing [C, D] means that we prefer to link B -- depending on how we---   set things up, this means that we should also link their test suites.-db6 :: ExampleDb-db6 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]-  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]-  , Right $ exAv "D" 1 [ExAny "B"]-  ]---- Packages with setup dependencies------ Install..--- * B: Simple example, just make sure setup deps are taken into account at all--- * C: Both the package and the setup script depend on any version of A.---      In this case we prefer to link--- * D: Variation on C.1 where the package requires a specific (not latest)---      version but the setup dependency is not fixed. Again, we prefer to---      link (picking the older version)--- * E: Variation on C.2 with the setup dependency the more inflexible.---      Currently, in this case we do not see the opportunity to link because---      we consider setup dependencies after normal dependencies; we will---      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick---      A.1 instead. This isn't so easy to fix (if we want to fix it at all);---      in particular, considering setup dependencies _before_ other deps is---      not an improvement, because in general we would prefer to link setup---      setups to package deps, rather than the other way around. (For example,---      if we change this ordering then the test for D would start to install---      two versions of A).--- * F: The package and the setup script depend on different versions of A.---      This will only work if setup dependencies are considered independent.-db7 :: ExampleDb-db7 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]-  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]-  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]-  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]-  ]---- If we install C and D together (not as independent goals), we need to build--- both B.1 and B.2, both of which depend on A.-db8 :: ExampleDb-db8 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "B" 2 [ExAny "A"]-  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]-  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]-  ]---- Extended version of `db8` so that we have nested setup dependencies-db9 :: ExampleDb-db9 = db8 ++ [-    Right $ exAv "E" 1 [ExAny "C"]-  , Right $ exAv "E" 2 [ExAny "D"]-  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]-  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]-  ]---- Multiple already-installed packages with inter-dependencies, and one package--- (C) that depends on package A-1 for its setup script and package A-2 as a--- library dependency.-db10 :: ExampleDb-db10 =-  let rts         = exInst "rts"         1 "rts-inst"         []-      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]-      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]-      a1          = exInst "A"           1 "A1-inst"          [base]-      a2          = exInst "A"           2 "A2-inst"          [base]-  in [-      Left rts-    , Left ghc_prim-    , Left base-    , Left a1-    , Left a2-    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]-    ]---- | This database tests that a package's setup dependencies are correctly--- linked when the package is linked. See pull request #3268.------ When A and B are installed as independent goals, their dependencies on C must--- be linked, due to the single instance restriction. Since C depends on D, 0.D--- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D--- and 1.C-setup.D must be linked. However, D's two link groups must remain--- independent. The solver should be able to choose D-1 for C's library and D-2--- for C's setup script.-dbSetupDeps :: ExampleDb-dbSetupDeps = [-    Right $ exAv "A" 1 [ExAny "C"]-  , Right $ exAv "B" 1 [ExAny "C"]-  , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]-  , Right $ exAv "D" 1 []-  , Right $ exAv "D" 2 []-  ]---- | Tests for dealing with base shims-db11 :: ExampleDb-db11 =-  let base3 = exInst "base" 3 "base-3-inst" [base4]-      base4 = exInst "base" 4 "base-4-inst" []-  in [-      Left base3-    , Left base4-    , Right $ exAv "A" 1 [ExFix "base" 3]-    ]---- | Slightly more realistic version of db11 where base-3 depends on syb--- This means that if a package depends on base-3 and on syb, then they MUST--- share the version of syb------ * Package A relies on base-3 (which relies on base-4)--- * Package B relies on base-4--- * Package C relies on both A and B--- * Package D relies on base-3 and on syb-2, which is not possible because---     base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)--- * Package E relies on base-4 and on syb-2, which is fine.-db12 :: ExampleDb-db12 =-  let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]-      base4 = exInst "base" 4 "base-4-inst" []-      syb1  = exInst "syb" 1 "syb-1-inst" [base4]-  in [-      Left base3-    , Left base4-    , Left syb1-    , Right $ exAv "syb" 2 [ExFix "base" 4]-    , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]-    , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]-    , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]-    , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]-    , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]-    ]--db13 :: ExampleDb-db13 = [-    Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 []-  , Right $ exAv "A" 3 []-  ]---- | Database with some cycles------ * Simplest non-trivial cycle: A -> B and B -> A--- * There is a cycle C -> D -> C, but it can be broken by picking the---   right flag assignment.-db14 :: ExampleDb-db14 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "A"]-  , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]-  , Right $ exAv "D" 1 [ExAny "C"]-  , Right $ exAv "E" 1 []-  ]---- | Cycles through setup dependencies------ The first cycle is unsolvable: package A has a setup dependency on B,--- B has a regular dependency on A, and we only have a single version available--- for both.------ The second cycle can be broken by picking different versions: package C-2.0--- has a setup dependency on D, and D has a regular dependency on C-*. However,--- version C-1.0 is already available (perhaps it didn't have this setup dep).--- Thus, we should be able to break this cycle even if we are installing package--- E, which explictly depends on C-2.0.-db15 :: ExampleDb-db15 = [-    -- First example (real cycle, no solution)-    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]-  , Right $ exAv   "B" 1            [ExAny "A"]-    -- Second example (cycle can be broken by picking versions carefully)-  , Left  $ exInst "C" 1 "C-1-inst" []-  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]-  , Right $ exAv   "D" 1            [ExAny "C"  ]-  , Right $ exAv   "E" 1            [ExFix "C" 2]-  ]---- | Check that the solver can backtrack after encountering the SIR (issue #2843)------ When A and B are installed as independent goals, the single instance--- restriction prevents B from depending on C.  This database tests that the--- solver can backtrack after encountering the single instance restriction and--- choose the only valid flag assignment (-flagA +flagB):------ > flagA flagB  B depends on--- >  On    _     C-*--- >  Off   On    E-*               <-- only valid flag assignment--- >  Off   Off   D-2.0, C-*------ Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D,--- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have--- C in the transitive closure of B's dependencies, because that would mean we--- would need two instances of C: one built against D-1.0 and one built against--- D-2.0.-db16 :: ExampleDb-db16 = [-    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]-  , Right $ exAv "B" 1 [ ExFix "D" 2-                       , exFlag "flagA"-                             [ExAny "C"]-                             [exFlag "flagB"-                                 [ExAny "E"]-                                 [ExAny "C"]]]-  , Right $ exAv "C" 1 [ExAny "D"]-  , Right $ exAv "D" 1 []-  , Right $ exAv "D" 2 []-  , Right $ exAv "E" 1 []-  ]---- | This database checks that when the solver discovers a constraint on a--- package's version after choosing to link that package, it can backtrack to--- try alternative versions for the linked-to package. See pull request #3327.------ When A and B are installed as independent goals, their dependencies on C--- must be linked. Since C depends on D, A and B's dependencies on D must also--- be linked. This test relies on the fact that the solver chooses D-2 for both--- 0.D and 1.D before it encounters the test suites' constraints. The solver--- must backtrack to try D-1 for both 0.D and 1.D.-db17 :: ExampleDb-db17 = [-    Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]-  , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]-  , Right $ exAv "C" 1 [ExAny "D"]-  , Right $ exAv "D" 1 []-  , Right $ exAv "D" 2 []-  ]---- | Issue #2834--- When both A and B are installed as independent goals, their dependencies on--- C must be linked. The only combination of C's flags that is consistent with--- A and B's dependencies on D is -flagA +flagB. This database tests that the--- solver can backtrack to find the right combination of flags (requiring F, but--- not E or G) and apply it to both 0.C and 1.C.------ > flagA flagB  C depends on--- >  On    _     D-1, E-*--- >  Off   On    F-*        <-- Only valid choice--- >  Off   Off   D-2, G-*------ The single instance restriction means we cannot have one instance of C--- built against D-1 and one instance built against D-2; since A depends on--- D-1, and B depends on C-2, it is therefore important that C cannot depend--- on any version of D.-db18 :: ExampleDb-db18 = [-    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]-  , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]-  , Right $ exAv "C" 1 [exFlag "flagA"-                           [ExFix "D" 1, ExAny "E"]-                           [exFlag "flagB"-                               [ExAny "F"]-                               [ExFix "D" 2, ExAny "G"]]]-  , Right $ exAv "D" 1 []-  , Right $ exAv "D" 2 []-  , Right $ exAv "E" 1 []-  , Right $ exAv "F" 1 []-  , Right $ exAv "G" 1 []-  ]---- | Tricky test case with independent goals (issue #2842)------ Suppose we are installing D, E, and F as independent goals:------ * D depends on A-* and C-1, requiring A-1 to be built against C-1--- * E depends on B-* and C-2, requiring B-1 to be built against C-2--- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built---     against the same version of C, violating the single instance restriction.------ We can visualize this DB as:------ >    C-1   C-2--- >    /|\   /|\--- >   / | \ / | \--- >  /  |  X  |  \--- > |   | / \ |   |--- > |   |/   \|   |--- > |   +     +   |--- > |   |     |   |--- > |   A     B   |--- >  \  |\   /|  /--- >   \ | \ / | /--- >    \|  V  |/--- >     D  F  E-db19 :: ExampleDb-db19 = [-    Right $ exAv "A" 1 [ExAny "C"]-  , Right $ exAv "B" 1 [ExAny "C"]-  , Right $ exAv "C" 1 []-  , Right $ exAv "C" 2 []-  , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]-  , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]-  , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]-  ]---- | This database tests that the solver correctly backjumps when dependencies--- of linked packages are not linked. It is an example where the conflict set--- from enforcing the single instance restriction is not sufficient. See pull--- request #3327.------ When C, A, and B are installed as independent goals, the solver first--- chooses 0.C-1 and 0.D-2. When choosing dependencies for A and B, it links--- 1.D and 2.D to 0.D. Finally, the solver discovers the test's constraint on--- D. It must backjump to try 1.D-1 and then link 2.D to 1.D.-db20 :: ExampleDb-db20 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "D" 1]-  , Right $ exAv "C" 1 [ExFix "D" 2]-  , Right $ exAv "D" 1 []-  , Right $ exAv "D" 2 []-  ]---- | Test the trace messages that we get when a package refers to an unknown pkg------ TODO: Currently we don't actually test the trace messages, and this particular--- test still suceeds. The trace can only be verified by hand.-db21 :: ExampleDb-db21 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown-  , Right $ exAv "B" 1 []-  ]---- | A variant of 'db21', which actually fails.-db22 :: ExampleDb-db22 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "A" 2 [ExAny "C"]-  ]---- | Database for (unsuccessfully) trying to expose a bug in the handling--- of implied linking constraints. The question is whether an implied linking--- constraint should only have the introducing package in its conflict set,--- or also its link target.------ It turns out that as long as the Single Instance Restriction is in place,--- it does not matter, because there will aways be an option that is failing--- due to the SIR, which contains the link target in its conflict set.------ Even if the SIR is not in place, if there is a solution, one will always--- be found, because without the SIR, linking is always optional, but never--- necessary.----db23 :: ExampleDb-db23 = [-    Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]-  , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2]-  , Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "C"]-  , Right $ exAv "C" 1 []-  , Right $ exAv "C" 2 []-  ]---- | A simplified version of 'db23'.-db24 :: ExampleDb-db24 = [-    Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]-  , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2]-  , Right $ exAv "A" 1 []-  , Right $ exAv "A" 2 [ExAny "B"]-  , Right $ exAv "B" 1 []-  , Right $ exAv "B" 2 []-  ]--dbExts1 :: ExampleDb-dbExts1 = [-    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]-  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B"]-  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]-  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]-  ]--dbLangs1 :: ExampleDb-dbLangs1 = [-    Right $ exAv "A" 1 [ExLang Haskell2010]-  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]-  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]-  ]---- | cabal must set enable-lib to false in order to avoid the unavailable--- dependency. Flags are true by default. The flag choice causes "pkg" to--- depend on "false-dep".-testBuildable :: String -> ExampleDependency -> TestTree-testBuildable testName unavailableDep =-    runTest $ mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected-  where-    expected = SolverSuccess [("false-dep", 1), ("pkg", 1)]-    db = [-        Right $ exAv "pkg" 1-            [ unavailableDep-            , ExFlag "enable-lib" (Buildable []) NotBuildable ]-         `withTest`-            ExTest "test" [exFlag "enable-lib"-                              [ExAny "true-dep"]-                              [ExAny "false-dep"]]-      , Right $ exAv "true-dep" 1 []-      , Right $ exAv "false-dep" 1 []-      ]---- | cabal must choose -flag1 +flag2 for "pkg", which requires packages--- "flag1-false" and "flag2-true".-dbBuildable1 :: ExampleDb-dbBuildable1 = [-    Right $ exAv "pkg" 1-        [ ExAny "unknown"-        , ExFlag "flag1" (Buildable []) NotBuildable-        , ExFlag "flag2" (Buildable []) NotBuildable]-     `withTests`-        [ ExTest "optional-test"-              [ ExAny "unknown"-              , ExFlag "flag1"-                    (Buildable [])-                    (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]-        , ExTest "test" [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]-                        , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]-        ]-  , Right $ exAv "flag1-true" 1 []-  , Right $ exAv "flag1-false" 1 []-  , Right $ exAv "flag2-true" 1 []-  , Right $ exAv "flag2-false" 1 []-  ]---- | Package databases for testing @pkg-config@ dependencies.-dbPC1 :: ExampleDb-dbPC1 = [-    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]-  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]-  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]-  , Right $ exAv "C" 1 [ExAny "B"]-  ]---- | cabal must pick B-2 to avoid the unknown dependency.-dbBuildable2 :: ExampleDb-dbBuildable2 = [-    Right $ exAv "A" 1 [ExAny "B"]-  , Right $ exAv "B" 1 [ExAny "unknown"]-  , Right $ exAv "B" 2-        [ ExAny "unknown"-        , ExFlag "disable-lib" NotBuildable (Buildable [])-        ]-  , Right $ exAv "B" 3 [ExAny "unknown"]-  ]
tests/UnitTests/Distribution/Client/FileMonitor.hs view
@@ -15,7 +15,7 @@ import Distribution.Verbosity (silent)  import Distribution.Client.FileMonitor-import Distribution.Client.Compat.Time+import Distribution.Compat.Time  import Test.Tasty import Test.Tasty.HUnit@@ -24,6 +24,7 @@ tests :: Int -> [TestTree] tests mtimeChange =   [ testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange+  , testCase "sanity check dirs"     $ testDirChangeSanity mtimeChange   , testCase "no monitor cache"      testNoMonitorCache   , testCase "corrupt monitor cache" testCorruptMonitorCache   , testCase "empty monitor"         testEmptyMonitor@@ -34,6 +35,7 @@   , testCase "remove file"           testRemoveFile   , testCase "non-existent file"     testNonExistentFile   , testCase "changed file type"     $ testChangedFileType mtimeChange+  , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange    , testGroup "glob matches"     [ testCase "no change"           testGlobNoChange@@ -69,6 +71,8 @@   , testCase "value updated"         testValueUpdated   ] +-- Check the file system behaves the way we expect it to+ -- we rely on file mtimes having a reasonable resolution testFileMTimeSanity :: Int -> Assertion testFileMTimeSanity mtimeChange =@@ -81,6 +85,62 @@       t2 <- getModTime (dir </> "a")       assertBool "expected different file mtimes" (t2 > t1) +-- We rely on directories changing mtime when entries are added or removed+testDirChangeSanity :: Int -> Assertion+testDirChangeSanity mtimeChange =+  withTempDirectory silent "." "dir-mtime-" $ \dir -> do++    expectMTimeChange dir "file add" $+      IO.writeFile (dir </> "file") "content"++    expectMTimeSame dir "file content change" $+      IO.writeFile (dir </> "file") "new content"++    expectMTimeChange dir "file del" $+      IO.removeFile (dir </> "file")++    expectMTimeChange dir "subdir add" $+      IO.createDirectory (dir </> "dir")++    expectMTimeSame dir "subdir file add" $+      IO.writeFile (dir </> "dir" </> "file") "content"++    expectMTimeChange dir "subdir file move in" $+      IO.renameFile (dir </> "dir" </> "file") (dir </> "file")++    expectMTimeChange dir "subdir file move out" $+      IO.renameFile (dir </> "file") (dir </> "dir" </> "file")++    expectMTimeSame dir "subdir dir add" $+      IO.createDirectory (dir </> "dir" </> "subdir")++    expectMTimeChange dir "subdir dir move in" $+      IO.renameDirectory (dir </> "dir" </> "subdir") (dir </> "subdir")++    expectMTimeChange dir "subdir dir move out" $+      IO.renameDirectory (dir </> "subdir") (dir </> "dir" </> "subdir")++  where+    expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO ()+                                       -> Assertion++    expectMTimeChange dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected dir mtime change on " ++ descr) (t' > t)++    expectMTimeSame dir descr action = do+      t  <- getModTime dir+      threadDelay mtimeChange+      action+      t' <- getModTime dir+      assertBool ("expected same dir mtime on " ++ descr) (t' == t)+++-- Now for the FileMonitor tests proper...+ -- first run, where we don't even call updateMonitor testNoMonitorCache :: Assertion testNoMonitorCache =@@ -327,6 +387,34 @@         touch' root "a"         reason <- expectMonitorChanged root monitor ()         reason @?= MonitoredFileChanged "a"++-- Monitoring the same file with two different kinds of monitor should work+-- both should be kept, and both checked for changes.+-- We had a bug where only one monitor kind was kept per file.+-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178+testMultipleMonitorKinds :: Int -> Assertion+testMultipleMonitorKinds mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a", monitorFileHashed "a"]+    threadDelay mtimeChange+    touchFile root "a" -- not changing content, just mtime+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    createDir root "dir"+    updateMonitor root monitor [monitorDirectory "dir",+                                monitorDirectoryExistence "dir"] () ()+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "a") -- changing dir mtime, not existence+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "dir"   ------------------
+ tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,60 @@+module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where++import Distribution.Text+import Data.Time+import Data.Time.Clock.POSIX++import Distribution.Client.IndexUtils.Timestamp++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+    [ testProperty "Timestamp1" prop_timestamp1+    , testProperty "Timestamp2" prop_timestamp2+    , testProperty "Timestamp3" prop_timestamp3+    , testProperty "Timestamp4" prop_timestamp4+    , testProperty "Timestamp5" prop_timestamp5+    ]++-- test unixtime format parsing+prop_timestamp1 :: Int -> Bool+prop_timestamp1 t0 = Just t == simpleParse ('@':show t0)+  where+    t = toEnum t0 :: Timestamp++-- test display/simpleParse roundtrip+prop_timestamp2 :: Int -> Bool+prop_timestamp2 t0+  | t /= nullTimestamp  = simpleParse (display t) == Just t+  | otherwise           = display t == ""+  where+    t = toEnum t0 :: Timestamp++-- test display against reference impl+prop_timestamp3 :: Int -> Bool+prop_timestamp3 t0+  | t /= nullTimestamp  = refDisp t == display t+  | otherwise           = display t == ""+  where+    t = toEnum t0 :: Timestamp++    refDisp = maybe undefined (formatTime undefined "%FT%TZ")+              . timestampToUTCTime++-- test utcTimeToTimestamp/timestampToUTCTime roundtrip+prop_timestamp4 :: Int -> Bool+prop_timestamp4 t0+  | t /= nullTimestamp  = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t+  | otherwise           = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp++prop_timestamp5 :: Int -> Bool+prop_timestamp5 t0+  | t /= nullTimestamp = timestampToUTCTime t == Just ut+  | otherwise          = timestampToUTCTime t == Nothing+  where+    t = toEnum t0 :: Timestamp+    ut = posixSecondsToUTCTime (fromIntegral t0)
+ tests/UnitTests/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE ConstraintKinds #-}+module UnitTests.Distribution.Client.InstallPlan (tests) where++import           Distribution.Package+import           Distribution.Version+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)+import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph (IsNode(..))+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.PackageFixedDeps+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Client.Types+import           Distribution.Client.JobControl++import Data.Graph+import Data.Array hiding (index)+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Data.IORef+import Control.Monad+import Control.Concurrent (threadDelay)+import System.Random+import Test.QuickCheck++import Test.Tasty+import Test.Tasty.QuickCheck+++tests :: [TestTree]+tests =+  [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder+  , testProperty "executionOrder"          prop_executionOrder+  , testProperty "execute serial"          prop_execute_serial+  , testProperty "execute parallel"        prop_execute_parallel+  , testProperty "execute/executionOrder"  prop_execute_vs_executionOrder+  ]++prop_reverseTopologicalOrder :: TestInstallPlan -> Bool+prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =+    isReverseTopologicalOrder+      graph+      (map (toVertex . installedUnitId)+           (InstallPlan.reverseTopologicalOrder plan))++-- | @executionOrder@ is in reverse topological order+prop_executionOrder :: TestInstallPlan -> Bool+prop_executionOrder (TestInstallPlan plan graph toVertex _) =+    isReversePartialTopologicalOrder graph (map toVertex pkgids)+ && allConfiguredPackages plan == Set.fromList pkgids+  where+    pkgids = map installedUnitId (InstallPlan.executionOrder plan)++-- | @execute@ is in reverse topological order+prop_execute_serial :: TestInstallPlan -> Property+prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property+prop_execute_parallel (Positive (Small maxJobLimit))+                      tplan@(TestInstallPlan plan graph toVertex _) =+    ioProperty $ do+      jobCtl <- newParallelJobControl maxJobLimit+      pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do+                  delay <- randomRIO (0,1000)+                  threadDelay delay+      return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)+            && allConfiguredPackages plan == Set.fromList pkgids++-- | return the packages that are visited by execute, in order.+executeTestInstallPlan :: JobControl IO (UnitId, Either () ())+                       -> TestInstallPlan+                       -> (TestPkg -> IO ())+                       -> IO [UnitId]+executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do+    resultsRef <- newIORef []+    _ <- InstallPlan.execute jobCtl False (const ())+                             plan $ \(ReadyPackage pkg) -> do+           visit pkg+           atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ())+           return (Right ())+    fmap reverse (readIORef resultsRef)++-- | @execute@ visits the packages in the same order as @executionOrder@+prop_execute_vs_executionOrder :: TestInstallPlan -> Property+prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =+    ioProperty $ do+      jobCtl <- newSerialJobControl+      pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())+      let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)+      return (pkgids == pkgids')+++--------------------------+-- Property helper utils+--++-- | A graph topological ordering is a linear ordering of its vertices such+-- that for every directed edge uv from vertex u to vertex v, u comes before v+-- in the ordering.+--+-- A reverse topological ordering is the swapped: for every directed edge uv+-- from vertex u to vertex v, v comes before u in the ordering.+--+isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool+isReverseTopologicalOrder g vs =+    and [ ixs ! u > ixs ! v+        | let ixs = array (bounds g) (zip vs [0::Int ..])+        , (u,v) <- edges g ]++isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool+isReversePartialTopologicalOrder g vs =+    and [ case (ixs ! u, ixs ! v) of+            (Just ixu, Just ixv) -> ixu > ixv+            _                    -> True+        | let ixs = array (bounds g)+                          (zip (range (bounds g)) (repeat Nothing) ++ +                           zip vs (map Just [0::Int ..]))+        , (u,v) <- edges g ]++allConfiguredPackages :: HasUnitId srcpkg+                      => GenericInstallPlan ipkg srcpkg -> Set UnitId+allConfiguredPackages plan =+    Set.fromList+      [ installedUnitId pkg+      | InstallPlan.Configured pkg <- InstallPlan.toList plan ]+++--------------------+-- Test generators+--++data TestInstallPlan = TestInstallPlan+                         (GenericInstallPlan TestPkg TestPkg)+                         Graph+                         (UnitId -> Vertex)+                         (Vertex -> UnitId)++instance Show TestInstallPlan where+  show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan++data TestPkg = TestPkg PackageId UnitId [UnitId]+  deriving (Eq, Show)++instance IsNode TestPkg where+  type Key TestPkg = UnitId+  nodeKey (TestPkg _ ipkgid _) = ipkgid+  nodeNeighbors (TestPkg _ _ deps) = deps+++instance Package TestPkg where+  packageId (TestPkg pkgid _ _) = pkgid++instance HasUnitId TestPkg where+  installedUnitId (TestPkg _ ipkgid _) = ipkgid++instance PackageFixedDeps TestPkg where+  depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps++instance PackageInstalled TestPkg where+  installedDepends (TestPkg _ _ deps) = deps++instance Arbitrary TestInstallPlan where+  arbitrary = arbitraryTestInstallPlan++arbitraryTestInstallPlan :: Gen TestInstallPlan+arbitraryTestInstallPlan = do+    graph <- arbitraryAcyclicGraph+               (choose (2,5))+               (choose (1,5))+               0.3++    plan  <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph++    let toVertexMap   = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ]+        fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ]+        toVertex      = (toVertexMap   Map.!)+        fromVertex    = (fromVertexMap Map.!)++    return (TestInstallPlan plan graph toVertex fromVertex)+  where+    mkTestPkg pkgv depvs =+        return (TestPkg pkgid ipkgid deps)+      where+        pkgid  = mkPkgId pkgv+        ipkgid = mkUnitIdV pkgv+        deps   = map mkUnitIdV depvs+    mkUnitIdV = mkUnitId . show+    mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v))+                                  (mkVersion [1])+++-- | Generate a random 'InstallPlan' following the structure of an existing+-- 'Graph'.+--+-- It takes generators for installed and source packages and the chance that+-- each package is installed (for those packages with no prerequisites).+--+arbitraryInstallPlan :: (IsUnit ipkg,+                         IsUnit srcpkg)+                     => (Vertex -> [Vertex] -> Gen ipkg)+                     -> (Vertex -> [Vertex] -> Gen srcpkg)+                     -> Float+                     -> Graph+                     -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)+arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do++    (ipkgvs, srcpkgvs) <-+      fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))+            . partition snd) $+      sequence+        [ do isipkg <- if isRoot then pick ipkgProportion+                                 else return False+             return (v, isipkg)+        | (v,n) <- assocs (outdegree graph)+        , let isRoot = n == 0 ]++    ipkgs   <- sequence+                 [ mkIPkg pkgv depvs+                 | pkgv <- ipkgvs+                 , let depvs  = graph ! pkgv+                 ]+    srcpkgs <- sequence+                 [ mkSrcPkg pkgv depvs+                 | pkgv <- srcpkgvs+                 , let depvs  = graph ! pkgv+                 ]+    let index = Graph.fromDistinctList+                   (map InstallPlan.PreExisting ipkgs+                 ++ map InstallPlan.Configured  srcpkgs)+    return $ InstallPlan.new (IndependentGoals False) index+++-- | Generate a random directed acyclic graph, based on the algorithm presented+-- here <http://stackoverflow.com/questions/12790337/generating-a-random-dag>+--+-- It generates a DAG based on ranks of nodes. Nodes in each rank can only+-- have edges to nodes in subsequent ranks.+--+-- The generator is paramterised by a generator for the number of ranks and+-- the number of nodes within each rank. It is also paramterised by the+-- chance that each node in each rank will have an edge from each node in+-- each previous rank. Thus a higher chance will produce a more densely+-- connected graph.+--+arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph+arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do+    nranks    <- genNRanks+    rankSizes <- replicateM nranks genNPerRank+    let rankStarts = scanl (+) 0 rankSizes+        rankRanges = drop 1 (zip rankStarts (tail rankStarts))+        totalRange = sum rankSizes+    rankEdges <- mapM (uncurry genRank) rankRanges+    return $ buildG (0, totalRange-1) (concat rankEdges)+  where+    genRank :: Vertex -> Vertex -> Gen [Edge]+    genRank rankStart rankEnd =+      filterM (const (pick edgeChance))+        [ (i,j)+        | i <- [0..rankStart-1]+        , j <- [rankStart..rankEnd-1]+        ]++pick :: Float -> Gen Bool+pick chance = do+    p <- choose (0,1)+    return (p < chance)+++--------------------------------+-- Inspecting generated graphs+--++{-+-- Handy util for checking the generated graphs look sensible+writeDotFile :: FilePath -> Graph -> IO ()+writeDotFile file = writeFile file . renderDotGraph++renderDotGraph :: Graph -> String+renderDotGraph graph =+  unlines (+      [header+      ,graphDefaultAtribs+      ,nodeDefaultAtribs+      ,edgeDefaultAtribs]+    ++ map renderNode (vertices graph)+    ++ map renderEdge (edges graph)+    ++ [footer]+  )+  where+    renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++  "\"];"++    renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];"+++header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String++header = "digraph packages {"+footer = "}"++graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];"+nodeDefaultAtribs  = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];"+edgeDefaultAtribs  = "\tedge [fontsize=10];"+-}
+ tests/UnitTests/Distribution/Client/JobControl.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveDataTypeable #-}+module UnitTests.Distribution.Client.JobControl (tests) where++import Distribution.Client.JobControl++import Data.List+import Data.Maybe+import Data.IORef+import Control.Monad+import Control.Concurrent (threadDelay)+import Control.Exception  (Exception, try, throwIO)+import Data.Typeable      (Typeable)+import qualified Data.Set as Set++import Test.Tasty+import Test.Tasty.QuickCheck hiding (collect)+++tests :: [TestTree]+tests =+  [ testGroup "serial"+      [ testProperty "submit batch"       prop_submit_serial+      , testProperty "submit batch"       prop_remaining_serial+      , testProperty "submit interleaved" prop_interleaved_serial+      , testProperty "concurrent jobs"    prop_concurrent_serial+      , testProperty "cancel"             prop_cancel_serial+      , testProperty "exceptions"         prop_exception_serial+      ]+  , testGroup "parallel"+      [ testProperty "submit batch"       prop_submit_parallel+      , testProperty "submit batch"       prop_remaining_parallel+      , testProperty "submit interleaved" prop_interleaved_parallel+      , testProperty "concurrent jobs"    prop_concurrent_parallel+      , testProperty "cancel"             prop_cancel_parallel+      , testProperty "exceptions"         prop_exception_parallel+      ]+  ]+++prop_submit_serial :: [Int] -> Property+prop_submit_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit jobCtl xs++prop_submit_parallel :: Positive (Small Int) -> [Int] -> Property+prop_submit_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit jobCtl xs++prop_remaining_serial :: [Int] -> Property+prop_remaining_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_remaining jobCtl xs++prop_remaining_parallel :: Positive (Small Int) -> [Int] -> Property+prop_remaining_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_remaining jobCtl xs++prop_interleaved_serial :: [Int] -> Property+prop_interleaved_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_submit_interleaved jobCtl xs++prop_interleaved_parallel :: Positive (Small Int) -> [Int] -> Property+prop_interleaved_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_submit_interleaved jobCtl xs++prop_submit :: JobControl IO Int -> [Int] -> IO Bool+prop_submit jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    return (sort xs == sort xs')++prop_remaining :: JobControl IO Int -> [Int] -> IO Bool+prop_remaining jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (return x)) xs+    xs' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs')++collectRemainingJobs :: Monad m => JobControl m a -> m [a]+collectRemainingJobs jobCtl = go []+  where+    go xs = do+      remaining <- remainingJobs jobCtl+      if remaining+        then do x <- collectJob jobCtl+                go (x:xs)+        else return xs++prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool+prop_submit_interleaved jobCtl xs = do+    xs' <- sequence+      [ spawn >> collect+      | let spawns   = map (\x -> spawnJob jobCtl (return (Just x))) xs+                    ++ repeat (return ())+            collects = replicate 5 (return Nothing)+                    ++ map (\_ -> collectJob jobCtl) xs+      , (spawn, collect) <- zip spawns collects+      ]+    return (sort xs == sort (catMaybes xs'))++prop_concurrent_serial :: NonNegative (Small Int) -> Property+prop_concurrent_serial (NonNegative (Small ntasks)) =+  ioProperty $ do+    jobCtl   <- newSerialJobControl+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property+prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) =+  ioProperty $ do+    jobCtl   <- newParallelJobControl maxJobLimit+    countRef <- newIORef (0 :: Int)+    replicateM_ ntasks (spawnJob jobCtl (task countRef))+    counts   <- replicateM ntasks (collectJob jobCtl)+    return $ length counts == ntasks+          && all (\(n0, n1) -> n0 >= 0 && n0 <  maxJobLimit+                            && n1 >  0 && n1 <= maxJobLimit) counts+             -- we do hit the concurrency limit (in the right circumstances)+          && if ntasks >= maxJobLimit*2 -- give us enough of a margin+               then any (\(_,n1) -> n1 == maxJobLimit) counts+               else True+  where+    task countRef = do+      n0 <- atomicModifyIORef countRef (\n -> (n+1, n))+      threadDelay 100+      n1 <- atomicModifyIORef countRef (\n -> (n-1, n))+      return (n0, n1)++prop_cancel_serial :: [Int] -> [Int] -> Property+prop_cancel_serial xs ys =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    mapM_ (\x -> spawnJob jobCtl (return x)) (xs++ys)+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return (sort xs == sort xs' && null ys')++prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property+prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    mapM_ (\x -> spawnJob jobCtl (threadDelay 100  >> return x)) (xs++ys)+    xs' <- mapM (\_ -> collectJob jobCtl) xs+    cancelJobs jobCtl+    ys' <- collectRemainingJobs jobCtl+    return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys)++data TestException = TestException Int+  deriving (Typeable, Show)++instance Exception TestException++prop_exception_serial :: [Either Int Int] -> Property+prop_exception_serial xs =+  ioProperty $ do+    jobCtl <- newSerialJobControl+    prop_exception jobCtl xs++prop_exception_parallel :: Positive (Small Int) -> [Either Int Int] -> Property+prop_exception_parallel (Positive (Small maxJobLimit)) xs =+  ioProperty $ do+    jobCtl <- newParallelJobControl maxJobLimit+    prop_exception jobCtl xs++prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool+prop_exception jobCtl xs = do+    mapM_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs+    xs' <- replicateM (length xs) $ do+             mx <- try (collectJob jobCtl)+             return $ case mx of+               Left (TestException n) -> Left  n+               Right               n  -> Right n+    return (sort xs == sort xs')+
tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -31,6 +31,11 @@ import Distribution.Utils.NubList import Network.URI +import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.Settings+ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy @@ -72,7 +77,7 @@   where     usingGhc76orOlder =       case buildCompilerId of-        CompilerId GHC v -> v < Version [7,7] []+        CompilerId GHC v -> v < mkVersion [7,7]         _                -> False  @@ -91,8 +96,11 @@   prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool-prop_roundtrip_legacytypes_all =+prop_roundtrip_legacytypes_all config =     roundtrip_legacytypes+      config {+        projectConfigProvenance = mempty+      }  prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool prop_roundtrip_legacytypes_packages config =@@ -100,6 +108,7 @@       config {         projectConfigBuildOnly       = mempty,         projectConfigShared          = mempty,+        projectConfigProvenance      = mempty,         projectConfigLocalPackages   = mempty,         projectConfigSpecificPackage = mempty       }@@ -136,7 +145,7 @@         . showLegacyProjectConfig         . convertToLegacyProjectConfig)           config of-      ParseOk _ x -> x == config+      ParseOk _ x -> x == config { projectConfigProvenance = mempty }       _           -> False  @@ -190,12 +199,13 @@ hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared hackProjectConfigShared config =     config {+      projectConfigProjectFile = mempty, -- not present within project files       projectConfigConstraints =       --TODO: [required eventually] parse ambiguity in constraint       -- "pkgname -any" as either any version or disabled flag "any".-        let ambiguous ((UserConstraintFlags _pkg flags), _) =-              (not . null) [ () | (FlagName name, False) <- flags-                                , "any" `isPrefixOf` name ]+        let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) =+              (not . null) [ () | (name, False) <- flags+                                , "any" `isPrefixOf` unFlagName name ]             ambiguous _ = False          in filter (not . ambiguous) (projectConfigConstraints config)     }@@ -240,19 +250,21 @@         <*> (map getPackageLocationString <$> arbitrary)         <*> shortListOf 3 arbitrary         <*> arbitrary-        <*> arbitrary <*> arbitrary         <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary         <*> (MapMappend . fmap getNonMEmpty . Map.fromList                <$> shortListOf 3 arbitrary)         -- package entries with no content are equivalent to         -- the entry not existing at all, so exclude empty -    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) =+    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) =       [ ProjectConfig x0' x1' x2' x3'-                      x4' x5' x6' (MapMappend (fmap getNonMEmpty x7'))-      | ((x0', x1', x2', x3'), (x4', x5', x6', x7'))+                      x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8'))+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8'))           <- shrink ((x0, x1, x2, x3),-                     (x4, x5, x6, fmap NonMEmpty (getMapMappend x7)))+                     (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8)))       ]  newtype PackageLocationString@@ -295,11 +307,10 @@         <*> arbitrary         <*> arbitraryNumJobs         <*> arbitrary-        <*> arbitrary                                           -- 12-        <*> (fmap getShortToken <$> arbitrary)         <*> arbitrary+        <*> arbitrary         <*> (fmap getShortToken <$> arbitrary)-        <*> (fmap getShortToken <$> arbitrary)                  -- 16+        <*> arbitrary         <*> (fmap getShortToken <$> arbitrary)         <*> (fmap getShortToken <$> arbitrary)       where@@ -308,19 +319,19 @@     shrink (ProjectConfigBuildOnly               x00 x01 x02 x03 x04 x05 x06 x07               x08 x09 x10 x11 x12 x13 x14 x15-              x16 x17) =+              x16) =       [ ProjectConfigBuildOnly           x00' x01' x02' x03' x04'           x05' x06' x07' x08' (postShrink_NumJobs x09')-          x10' x11' x12  x13' x14-          x15 x16 x17+          x10' x11' x12' x13  x14'+          x15  x16       | ((x00', x01', x02', x03', x04'),          (x05', x06', x07', x08', x09'),-         (x10', x11',       x13'))+         (x10', x11', x12',       x14'))           <- shrink                ((x00, x01, x02, x03, x04),                 (x05, x06, x07, x08, preShrink_NumJobs x09),-                (x10, x11,      x13))+                (x10, x11, x12,      x14))       ]       where         preShrink_NumJobs  = fmap (fmap Positive)@@ -329,17 +340,23 @@ instance Arbitrary ProjectConfigShared where     arbitrary =       ProjectConfigShared-        <$> arbitrary                                           --  4+        <$> arbitraryFlag arbitraryShortToken         <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary         <*> arbitraryFlag arbitraryShortToken+        <*> arbitraryFlag arbitraryShortToken         <*> arbitrary         <*> arbitrary         <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary         <*> arbitraryConstraints         <*> shortListOf 2 arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary+        <*> arbitrary       where         arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]         arbitraryConstraints =@@ -348,18 +365,24 @@     shrink (ProjectConfigShared               x00 x01 x02 x03 x04               x05 x06 x07 x08 x09-              x10 x11 x12 x13) =+              x10 x11 x12 x13 x14+              x15 x16 x17 x18 x19+              x20) =       [ ProjectConfigShared-          x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'-          x05' (postShrink_Constraints x06') x07' x08' x09'-          x10' x11' x12' x13'+          x00' x01' x02' (fmap getNonEmpty x03') (fmap getNonEmpty x04')+          x05' x06' x07' x08' (postShrink_Constraints x09')+          x10' x11' x12' x13' x14' x15' x16' x17' x18' x19' x20'       | ((x00', x01', x02', x03', x04'),          (x05', x06', x07', x08', x09'),-         (x10', x11', x12', x13'))+         (x10', x11', x12', x13', x14'),+         (x15', x16', x17', x18', x19'),+         x20')           <- shrink-               ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),-                (x05, preShrink_Constraints x06, x07, x08, x09),-                (x10, x11, x12, x13))+               ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04),+                (x05, x06, x07, x08, preShrink_Constraints x09),+                (x10, x11, x12, x13, x14),+                (x15, x16, x17, x18, x19),+                x20)       ]       where         preShrink_Constraints  = map fst@@ -369,6 +392,9 @@ projectConfigConstraintSource =      ConstraintSourceProjectConfig "TODO" +instance Arbitrary ProjectConfigProvenance where+    arbitrary = elements [Implicit, Explicit "cabal.project"]+ instance Arbitrary PackageConfig where     arbitrary =       PackageConfig@@ -399,6 +425,7 @@         <*> arbitrary <*> arbitrary         <*> arbitraryFlag arbitraryShortToken         <*> arbitrary+        <*> arbitrary         <*> arbitrary <*> arbitrary         <*> arbitrary         <*> arbitraryFlag arbitraryShortToken@@ -418,7 +445,7 @@               x15 x16 x17 x18 x19               x20 x21 x22 x23 x24               x25 x26 x27 x28 x29-              x30 x31 x32 x33 x34+              x30 x31 x32 x33 x33_1 x34               x35 x36 x37 x38 x39               x40) =       [ PackageConfig@@ -432,7 +459,7 @@                               x19'           x20' x21' x22' x23' x24'           x25' x26' x27' x28' x29'-          x30' x31' x32' x33' x34'+          x30' x31' x32' x33' x33_1' x34'           x35' x36' (fmap getNonEmpty x37') x38'                     (fmap getNonEmpty x39')           x40'@@ -442,7 +469,7 @@           (x15', x16', x17', x18', x19')),          ((x20', x21', x22', x23', x24'),           (x25', x26', x27', x28', x29'),-          (x30', x31', x32', x33', x34'),+          (x30', x31', x32', (x33', x33_1'), x34'),           (x35', x36', x37', x38', x39'),           (x40')))           <- shrink@@ -455,7 +482,7 @@                        x19)),                 ((x20, x21, x22, x23, x24),                  (x25, x26, x27, x28, x29),-                 (x30, x31, x32, x33, x34),+                 (x30, x31, x32, (x33, x33_1), x34),                  (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39),                  (x40)))       ]@@ -482,7 +509,7 @@                            <*> (fmap getShortToken <$> arbitrary)                            <*> (fmap getShortToken <$> arbitrary)                            <*> (fmap getShortToken <$> arbitrary))-                `suchThat` (/= emptySourceRepo)+                `suchThat` (/= emptySourceRepo RepoThis)      shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =       [ repo@@ -499,14 +526,9 @@                               (fmap getShortToken x4')                               (fmap getShortToken x5')                               (fmap getShortToken x6')-      , repo /= emptySourceRepo+      , repo /= emptySourceRepo RepoThis       ] -emptySourceRepo :: SourceRepo-emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing-                                      Nothing Nothing Nothing-- instance Arbitrary RepoType where     arbitrary = elements knownRepoTypes @@ -527,7 +549,7 @@         <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  4         <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  8         <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12-        <*> arbitrary <*> arbitrary                             -- 14+        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16  instance Arbitrary PackageDB where     arbitrary = oneof [ pure GlobalPackageDB@@ -549,21 +571,36 @@           shortListOf1 5 (oneof [ choose ('0', '9')                                 , choose ('a', 'f') ]) +instance Arbitrary UserConstraintScope where+    arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary+                      , UserAnySetupQualifier <$> arbitrary+                      , UserAnyQualifier <$> arbitrary+                      ]++instance Arbitrary UserQualifier where+    arbitrary = oneof [ pure UserQualToplevel+                      , UserQualSetup <$> arbitrary++                      -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.+                      -- , UserQualExe <$> arbitrary <*> arbitrary+                      ]+ instance Arbitrary UserConstraint where-    arbitrary =-      oneof-        [ UserConstraintVersion   <$> arbitrary <*> arbitrary-        , UserConstraintInstalled <$> arbitrary-        , UserConstraintSource    <$> arbitrary-        , UserConstraintFlags     <$> arbitrary <*> shortListOf1 3 arbitrary-        , UserConstraintStanzas   <$> arbitrary <*> ((\x->[x]) <$> arbitrary)-        ]+    arbitrary = UserConstraint <$> arbitrary <*> arbitrary +instance Arbitrary PackageProperty where+    arbitrary = oneof [ PackagePropertyVersion <$> arbitrary+                      , pure PackagePropertyInstalled+                      , pure PackagePropertySource+                      , PackagePropertyFlags <$> shortListOf1 3 arbitrary+                      , PackagePropertyStanzas . (\x->[x]) <$> arbitrary+                      ]+ instance Arbitrary OptionalStanza where     arbitrary = elements [minBound..maxBound]  instance Arbitrary FlagName where-    arbitrary = FlagName <$> flagident+    arbitrary = mkFlagName <$> flagident       where         flagident   = lowercase <$> shortListOf1 5 (elements flagChars)                       `suchThat` (("-" /=) . take 1)@@ -572,15 +609,33 @@ instance Arbitrary PreSolver where     arbitrary = elements [minBound..maxBound] +instance Arbitrary ReorderGoals where+    arbitrary = ReorderGoals <$> arbitrary++instance Arbitrary CountConflicts where+    arbitrary = CountConflicts <$> arbitrary++instance Arbitrary StrongFlags where+    arbitrary = StrongFlags <$> arbitrary++instance Arbitrary AllowBootLibInstalls where+    arbitrary = AllowBootLibInstalls <$> arbitrary+ instance Arbitrary AllowNewer where-    arbitrary = oneof [ pure AllowNewerNone-                      , AllowNewerSome <$> shortListOf1 3 arbitrary-                      , pure AllowNewerAll+    arbitrary = AllowNewer <$> arbitrary++instance Arbitrary AllowOlder where+    arbitrary = AllowOlder <$> arbitrary++instance Arbitrary RelaxDeps where+    arbitrary = oneof [ pure RelaxDepsNone+                      , RelaxDepsSome <$> shortListOf1 3 arbitrary+                      , pure RelaxDepsAll                       ] -instance Arbitrary AllowNewerDep where-    arbitrary = oneof [ AllowNewerDep       <$> arbitrary-                      , AllowNewerDepScoped <$> arbitrary <*> arbitrary+instance Arbitrary RelaxedDep where+    arbitrary = oneof [ RelaxedDep       <$> arbitrary+                      , RelaxedDepScoped <$> arbitrary <*> arbitrary                       ]  instance Arbitrary ProfDetailLevel where
tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs view
@@ -5,7 +5,7 @@ import Distribution.Simple.Utils (withTempDirectory) import Distribution.Verbosity -import Distribution.Client.Compat.Time+import Distribution.Compat.Time import Distribution.Client.Sandbox.Timestamp  import Test.Tasty@@ -44,7 +44,7 @@   withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do     let fileName = dir </> "timestamp-record"     writeFile fileName fileContent-    tRec <- readTimestampFile fileName+    tRec <- readTimestampFile normal fileName     assertEqual "expected timestamp records to be equal"       expected tRec @@ -58,6 +58,6 @@   withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do     let fileName = dir </> "timestamp-record"     writeTimestampFile fileName timestampRecord-    tRec <- readTimestampFile fileName+    tRec <- readTimestampFile normal fileName     assertEqual "expected timestamp records to be equal"       timestampRecord tRec
+ tests/UnitTests/Distribution/Client/Store.hs view
@@ -0,0 +1,181 @@+module UnitTests.Distribution.Client.Store (tests) where++--import Control.Monad+--import Control.Concurrent (forkIO, threadDelay)+--import Control.Concurrent.MVar+import qualified Data.Set as Set+import System.FilePath+import System.Directory+--import System.Random++import Distribution.Package (UnitId, mkUnitId)+import Distribution.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.Version  (mkVersion)+import Distribution.Verbosity (Verbosity, silent)+import Distribution.Simple.Utils (withTempDirectory)++import Distribution.Client.Store+import Distribution.Client.RebuildMonad++import Test.Tasty+import Test.Tasty.HUnit+++tests :: [TestTree]+tests =+  [ testCase "list content empty"  testListEmpty+  , testCase "install serial"      testInstallSerial+--, testCase "install parallel"    testInstallParallel+    --TODO: figure out some way to do a parallel test, see issue below+  ]+++testListEmpty :: Assertion+testListEmpty =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")++    assertStoreEntryExists storeDirLayout compid unitid False+    assertStoreContent tmp storeDirLayout compid        Set.empty+  where+    compid = CompilerId GHC (mkVersion [1,0])+    unitid = mkUnitId "foo-1.0-xyz"+++testInstallSerial :: Assertion+testInstallSerial =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")+        copyFiles file content dir = do+          -- we copy into a prefix inside the tmp dir and return the prefix+          let destprefix = dir </> "prefix"+          createDirectory destprefix+          writeFile (destprefix </> file) content+          return destprefix++    assertNewStoreEntry tmp storeDirLayout compid unitid1+                        (copyFiles "file1" "content-foo") (return ())+                        UseNewStoreEntry++    assertNewStoreEntry tmp storeDirLayout compid unitid1+                        (copyFiles "file1" "content-foo") (return ())+                        UseExistingStoreEntry++    assertNewStoreEntry tmp storeDirLayout compid unitid2+                        (copyFiles "file2" "content-bar") (return ())+                        UseNewStoreEntry++    let pkgDir :: UnitId -> FilePath+        pkgDir = storePackageDirectory storeDirLayout compid+    assertFileEqual (pkgDir unitid1 </> "file1") "content-foo"+    assertFileEqual (pkgDir unitid2 </> "file2") "content-bar"+  where+    compid  = CompilerId GHC (mkVersion [1,0])+    unitid1 = mkUnitId "foo-1.0-xyz"+    unitid2 = mkUnitId "bar-2.0-xyz"+++{-+-- unfortunately a parallel test like the one below is thwarted by the normal+-- process-internal file locking. If that locking were not in place then we+-- ought to get the blocking behaviour, but due to the normal Handle locking+-- it just fails instead.++testInstallParallel :: Assertion+testInstallParallel =+  withTempDirectory verbosity "." "store-" $ \tmp -> do+    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")++    sync1 <- newEmptyMVar+    sync2 <- newEmptyMVar+    outv  <- newEmptyMVar+    regv  <- newMVar (0 :: Int)++    sequence_+      [ do forkIO $ do+             let copyFiles dir = do+                   delay <- randomRIO (1,100000)+                   writeFile (dir </> "file") (show n)+                   putMVar  sync1 ()+                   readMVar sync2+                   threadDelay delay+                 register = do+                   modifyMVar_ regv (return . (+1))+                   threadDelay 200000+             o <- newStoreEntry verbosity storeDirLayout+                                compid unitid+                                copyFiles register+             putMVar outv (n, o)+      | n <- [0..9 :: Int] ]++    replicateM_ 10 (takeMVar sync1)+    -- all threads are in the copyFiles action concurrently, release them:+    putMVar  sync2 ()++    outcomes <- replicateM 10 (takeMVar outv)+    regcount <- readMVar regv+    let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ]++    assertEqual "num registrations" 1 regcount+    assertEqual "num registrations" 1 regcount'++    assertStoreContent tmp storeDirLayout compid (Set.singleton unitid)++    let pkgDir :: UnitId -> FilePath+        pkgDir = storePackageDirectory storeDirLayout compid+    case [ n | (n, UseNewStoreEntry) <- outcomes ] of+      [n] -> assertFileEqual (pkgDir unitid </> "file") (show n)+      _   -> assertFailure "impossible"++  where+    compid  = CompilerId GHC (mkVersion [1,0])+    unitid = mkUnitId "foo-1.0-xyz"+-}++-------------+-- Utils++assertNewStoreEntry :: FilePath -> StoreDirLayout+                    -> CompilerId -> UnitId+                    -> (FilePath -> IO FilePath) -> IO ()+                    -> NewStoreEntryOutcome+                    -> Assertion+assertNewStoreEntry tmp storeDirLayout compid unitid+                    copyFiles register expectedOutcome = do+    entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid+    outcome <- newStoreEntry verbosity storeDirLayout+                             compid unitid+                             copyFiles register+    assertEqual "newStoreEntry outcome" expectedOutcome outcome+    assertStoreEntryExists storeDirLayout compid unitid True+    let expected = Set.insert unitid entries+    assertStoreContent tmp storeDirLayout compid expected+++assertStoreEntryExists :: StoreDirLayout+                       -> CompilerId -> UnitId -> Bool+                       -> Assertion+assertStoreEntryExists storeDirLayout compid unitid expected = do+    actual <- doesStoreEntryExist storeDirLayout compid unitid+    assertEqual "store entry exists" expected actual+++assertStoreContent :: FilePath -> StoreDirLayout+                   -> CompilerId -> Set.Set UnitId+                   -> Assertion+assertStoreContent tmp storeDirLayout compid expected = do+    actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid+    assertEqual "store content" actual expected+++assertFileEqual :: FilePath -> String -> Assertion+assertFileEqual path expected = do+    exists <- doesFileExist path+    assertBool ("file does not exist:\n" ++ path) exists+    actual <- readFile path+    assertEqual ("file content for:\n" ++ path) expected actual+++verbosity :: Verbosity+verbosity = silent+
tests/UnitTests/Distribution/Client/Targets.hs view
@@ -2,57 +2,105 @@   tests   ) where -import Distribution.Client.Targets     (UserConstraint (..), readUserConstraint)-import Distribution.Compat.ReadP       (ReadP, readP_to_S)-import Distribution.Package            (PackageName (..))+import Distribution.Client.Targets     (UserQualifier(..)+                                       ,UserConstraintScope(..)+                                       ,UserConstraint(..), readUserConstraint)+import Distribution.Compat.ReadP       (readP_to_S)+import Distribution.Package            (mkPackageName)+import Distribution.PackageDescription (mkFlagName)+import Distribution.Version            (anyVersion, thisVersion, mkVersion) import Distribution.ParseUtils         (parseCommaList) import Distribution.Text               (parse) +import Distribution.Solver.Types.PackageConstraint (PackageProperty(..))+import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..))+ import Test.Tasty import Test.Tasty.HUnit  import Data.Char                       (isSpace)+import Data.List                       (intercalate) -tests :: [TestTree]-tests = [ testCase "readUserConstraint" readUserConstraintTest-        , testCase "parseUserConstraint" parseUserConstraintTest-        , testCase "readUserConstraints" readUserConstraintsTest-        ]+-- Helper function: makes a test group by mapping each element+-- of a list to a test case.+makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree+makeGroup name f xs = testGroup name $+                      zipWith testCase (map show [0 :: Integer ..]) (map f xs) -readUserConstraintTest :: Assertion-readUserConstraintTest =-  assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual+tests :: [TestTree]+tests =+  [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest)+      exampleConstraints+    +  , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest)+      exampleConstraints+  +  , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest)+      [-- First example only.+       (head exampleStrs, take 1 exampleUcs),+       -- All examples separated by commas.+       (intercalate ", " exampleStrs, exampleUcs)]+  ]   where-    pkgName  = "template-haskell"-    constr   = pkgName ++ " installed"+    (exampleStrs, exampleUcs) = unzip exampleConstraints -    expected = UserConstraintInstalled (PackageName pkgName)-    actual   = let (Right r) = readUserConstraint constr in r+exampleConstraints :: [(String, UserConstraint)]+exampleConstraints =+  [ ("template-haskell installed",+     UserConstraint (UserQualified UserQualToplevel (pn "template-haskell"))+                    PackagePropertyInstalled)+    +  , ("bytestring -any",+     UserConstraint (UserQualified UserQualToplevel (pn "bytestring"))+                    (PackagePropertyVersion anyVersion)) -parseUserConstraintTest :: Assertion-parseUserConstraintTest =-  assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual-  where-    pkgName  = "template-haskell"-    constr   = pkgName ++ " installed"+  , ("any.directory test",+     UserConstraint (UserAnyQualifier (pn "directory"))+                    (PackagePropertyStanzas [TestStanzas])) -    expected = [UserConstraintInstalled (PackageName pkgName)]-    actual   = [ x | (x, ys) <- readP_to_S parseUserConstraint constr-                   , all isSpace ys]+  , ("setup.Cabal installed",+     UserConstraint (UserAnySetupQualifier (pn "Cabal"))+                    PackagePropertyInstalled) -    parseUserConstraint :: ReadP r UserConstraint-    parseUserConstraint = parse+  , ("process:setup.bytestring ==5.2",+     UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))+                    (PackagePropertyVersion (thisVersion (mkVersion [5, 2]))))+    +  , ("network:setup.containers +foo -bar baz",+     UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers"))+                    (PackagePropertyFlags [(fn "foo", True),+                                           (fn "bar", False),+                                           (fn "baz", True)]))+    +  -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.+  --+  -- , ("foo:happy:exe.template-haskell test",+  --    UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))+  --                   (PackagePropertyStanzas [TestStanzas]))+  ]+  where+    pn = mkPackageName+    fn = mkFlagName -readUserConstraintsTest :: Assertion-readUserConstraintsTest =-  assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual+readUserConstraintTest :: String -> UserConstraint -> Assertion+readUserConstraintTest str uc =+  assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual   where-    pkgName  = "template-haskell"-    constr   = pkgName ++ " installed"+    expected = uc+    actual   = let Right r = readUserConstraint str in r -    expected = [[UserConstraintInstalled (PackageName pkgName)]]-    actual   = [ x | (x, ys) <- readP_to_S parseUserConstraints constr+parseUserConstraintTest :: String -> UserConstraint -> Assertion+parseUserConstraintTest str uc =+  assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual+  where+    expected = [uc]+    actual   = [ x | (x, ys) <- readP_to_S parse str                    , all isSpace ys] -    parseUserConstraints :: ReadP r [UserConstraint]-    parseUserConstraints = parseCommaList parse+readUserConstraintsTest :: String -> [UserConstraint] -> Assertion+readUserConstraintsTest str ucs =+  assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual+  where+    expected = [ucs]+    actual   = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str+                   , all isSpace ys]
+ tests/UnitTests/Distribution/Solver/Modular/DSL.hs view
@@ -0,0 +1,688 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | DSL for testing the modular solver+module UnitTests.Distribution.Solver.Modular.DSL (+    ExampleDependency(..)+  , Dependencies(..)+  , ExTest(..)+  , ExExe(..)+  , ExConstraint(..)+  , ExPreference(..)+  , ExampleDb+  , ExampleVersionRange+  , ExamplePkgVersion+  , ExamplePkgName+  , ExampleFlagName+  , ExFlag(..)+  , ExampleAvailable(..)+  , ExampleInstalled(..)+  , ExampleQualifier(..)+  , ExampleVar(..)+  , EnableAllTests(..)+  , exAv+  , exInst+  , exFlagged+  , exResolve+  , extractInstallPlan+  , declareFlags+  , withSetupDeps+  , withTest+  , withTests+  , withExe+  , withExes+  , runProgress+  , mkVersionRange+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++-- base+import Data.Either (partitionEithers)+import Data.List (elemIndex)+import Data.Ord (comparing)+import qualified Data.Map as Map++-- Cabal+import qualified Distribution.Compiler                  as C+import qualified Distribution.InstalledPackageInfo      as IPI+import           Distribution.License (License(..))+import qualified Distribution.ModuleName                as Module+import qualified Distribution.Package                   as C+  hiding (HasUnitId(..))+import qualified Distribution.Types.LegacyExeDependency as C+import qualified Distribution.Types.PkgconfigDependency as C+import qualified Distribution.Types.UnqualComponentName as C+import qualified Distribution.Types.CondTree            as C+import qualified Distribution.PackageDescription        as C+import qualified Distribution.PackageDescription.Check  as C+import qualified Distribution.Simple.PackageIndex       as C.PackageIndex+import           Distribution.Simple.Setup (BooleanFlag(..))+import qualified Distribution.System                    as C+import           Distribution.Text (display)+import qualified Distribution.Version                   as C+import Language.Haskell.Extension (Extension(..), Language(..))++-- cabal-install+import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+import Distribution.Client.Types+import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.Flag+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex      as CI.PackageIndex+import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackagePath as P+import qualified Distribution.Solver.Types.PkgConfigDb as PC+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Variable++{-------------------------------------------------------------------------------+  Example package database DSL++  In order to be able to set simple examples up quickly, we define a very+  simple version of the package database here explicitly designed for use in+  tests.++  The design of `ExampleDb` takes the perspective of the solver, not the+  perspective of the package DB. This makes it easier to set up tests for+  various parts of the solver, but makes the mapping somewhat awkward,  because+  it means we first map from "solver perspective" `ExampleDb` to the package+  database format, and then the modular solver internally in `IndexConversion`+  maps this back to the solver specific data structures.++  IMPLEMENTATION NOTES+  --------------------++  TODO: Perhaps these should be made comments of the corresponding data type+  definitions. For now these are just my own conclusions and may be wrong.++  * The difference between `GenericPackageDescription` and `PackageDescription`+    is that `PackageDescription` describes a particular _configuration_ of a+    package (for instance, see documentation for `checkPackage`). A+    `GenericPackageDescription` can be turned into a `PackageDescription` in+    two ways:++      a. `finalizePD` does the proper translation, by taking+         into account the platform, available dependencies, etc. and picks a+         flag assignment (or gives an error if no flag assignment can be found)+      b. `flattenPackageDescription` ignores flag assignment and just joins all+         components together.++    The slightly odd thing is that a `GenericPackageDescription` contains a+    `PackageDescription` as a field; both of the above functions do the same+    thing: they take the embedded `PackageDescription` as a basis for the result+    value, but override `library`, `executables`, `testSuites`, `benchmarks`+    and `buildDepends`.+  * The `condTreeComponents` fields of a `CondTree` is a list of triples+    `(condition, then-branch, else-branch)`, where the `else-branch` is+    optional.+-------------------------------------------------------------------------------}++type ExamplePkgName    = String+type ExamplePkgVersion = Int+type ExamplePkgHash    = String  -- for example "installed" packages+type ExampleFlagName   = String+type ExampleTestName   = String+type ExampleExeName    = String+type ExampleVersionRange = C.VersionRange++data Dependencies = NotBuildable | Buildable [ExampleDependency]+  deriving Show++data ExampleDependency =+    -- | Simple dependency on any version+    ExAny ExamplePkgName++    -- | Simple dependency on a fixed version+  | ExFix ExamplePkgName ExamplePkgVersion++    -- | Simple dependency on a range of versions, with an inclusive lower bound+    -- and an exclusive upper bound.+  | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion++    -- | Build-tools dependency+  | ExBuildToolAny ExamplePkgName++    -- | Build-tools dependency on a fixed version+  | ExBuildToolFix ExamplePkgName ExamplePkgVersion++    -- | Dependencies indexed by a flag+  | ExFlagged ExampleFlagName Dependencies Dependencies++    -- | Dependency on a language extension+  | ExExt Extension++    -- | Dependency on a language version+  | ExLang Language++    -- | Dependency on a pkg-config package+  | ExPkg (ExamplePkgName, ExamplePkgVersion)+  deriving Show++-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in+-- example source packages.+data ExFlag = ExFlag {+    exFlagName    :: ExampleFlagName+  , exFlagDefault :: Bool+  , exFlagType    :: FlagType+  } deriving Show++data ExTest = ExTest ExampleTestName [ExampleDependency]++data ExExe = ExExe ExampleExeName [ExampleDependency]++exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]+          -> ExampleDependency+exFlagged n t e = ExFlagged n (Buildable t) (Buildable e)++data ExConstraint =+    ExVersionConstraint ConstraintScope ExampleVersionRange+  | ExFlagConstraint ConstraintScope ExampleFlagName Bool++data ExPreference =+    ExPkgPref ExamplePkgName ExampleVersionRange+  | ExStanzaPref ExamplePkgName [OptionalStanza]++data ExampleAvailable = ExAv {+    exAvName    :: ExamplePkgName+  , exAvVersion :: ExamplePkgVersion+  , exAvDeps    :: ComponentDeps [ExampleDependency]++  -- Setting flags here is only necessary to override the default values of+  -- the fields in C.Flag.+  , exAvFlags   :: [ExFlag]+  } deriving Show++data ExampleVar =+    P ExampleQualifier ExamplePkgName+  | F ExampleQualifier ExamplePkgName ExampleFlagName+  | S ExampleQualifier ExamplePkgName OptionalStanza++data ExampleQualifier =+    None+  | Indep Int+  | Setup ExamplePkgName+  | IndepSetup Int ExamplePkgName++-- | Whether to enable tests in all packages in a test case.+newtype EnableAllTests = EnableAllTests Bool+  deriving BooleanFlag++-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',+-- given:+--+--      1. The name 'ExamplePkgName' of the available package,+--      2. The version 'ExamplePkgVersion' available+--      3. The list of dependency constraints 'ExampleDependency'+--         that this package has.  'ExampleDependency' provides+--         a number of pre-canned dependency types to look at.+--+exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]+     -> ExampleAvailable+exAv n v ds = ExAv { exAvName = n, exAvVersion = v+                   , exAvDeps = CD.fromLibraryDeps ds, exAvFlags = [] }++-- | Override the default settings (e.g., manual vs. automatic) for a subset of+-- a package's flags.+declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable+declareFlags flags ex = ex {+      exAvFlags = flags+    }++withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable+withSetupDeps ex setupDeps = ex {+      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps+    }++withTest :: ExampleAvailable -> ExTest -> ExampleAvailable+withTest ex test = withTests ex [test]++withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable+withTests ex tests =+  let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps)+                            | ExTest name deps <- tests]+  in ex { exAvDeps = exAvDeps ex <> testCDs }++withExe :: ExampleAvailable -> ExExe -> ExampleAvailable+withExe ex exe = withExes ex [exe]++withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable+withExes ex exes =+  let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps)+                           | ExExe name deps <- exes]+  in ex { exAvDeps = exAvDeps ex <> exeCDs }++-- | An installed package in 'ExampleDb'; construct me with 'exInst'.+data ExampleInstalled = ExInst {+    exInstName         :: ExamplePkgName+  , exInstVersion      :: ExamplePkgVersion+  , exInstHash         :: ExamplePkgHash+  , exInstBuildAgainst :: [ExamplePkgHash]+  } deriving Show++-- | Constructs an example installed package given:+--+--      1. The name of the package 'ExamplePkgName', i.e., 'String'+--      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'+--      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'+--         (just some unique identifier for the package.)+--      4. The 'ExampleInstalled' packages which this package was+--         compiled against.)+--+exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash+       -> [ExampleInstalled] -> ExampleInstalled+exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)++-- | An example package database is a list of installed packages+-- 'ExampleInstalled' and available packages 'ExampleAvailable'.+-- Generally, you want to use 'exInst' and 'exAv' to construct+-- these packages.+type ExampleDb = [Either ExampleInstalled ExampleAvailable]++type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a++type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a++exDbPkgs :: ExampleDb -> [ExamplePkgName]+exDbPkgs = map (either exInstName exAvName)++exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage+exAvSrcPkg ex =+    let pkgId = exAvPkgId ex++        flags :: [C.Flag]+        flags =+          let declaredFlags :: Map ExampleFlagName C.Flag+              declaredFlags =+                  Map.fromListWith+                      (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2])+                      [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex]++              usedFlags :: Map ExampleFlagName C.Flag+              usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]+                where+                  names = concatMap extractFlags $+                          CD.libraryDeps (exAvDeps ex)+                           ++ concatMap snd testSuites+                           ++ concatMap snd executables+          in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:+             Map.elems $ declaredFlags `Map.union` usedFlags++        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]+        executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]+        setup = case CD.setupDeps (exAvDeps ex) of+                  []   -> Nothing+                  deps -> Just C.SetupBuildInfo {+                            C.setupDepends = mkSetupDeps deps,+                            C.defaultSetupDepends = False+                          }+        package = SourcePackage {+            packageInfoId        = pkgId+          , packageSource        = LocalTarballPackage "<<path>>"+          , packageDescrOverride = Nothing+          , packageDescription   = C.GenericPackageDescription {+                C.packageDescription = C.emptyPackageDescription {+                    C.package        = pkgId+                  , C.setupBuildInfo = setup+                  , C.license = BSD3+                  , C.buildType = if isNothing setup+                                  then Just C.Simple+                                  else Just C.Custom+                  , C.category = "category"+                  , C.maintainer = "maintainer"+                  , C.description = "description"+                  , C.synopsis = "synopsis"+                  , C.licenseFiles = ["LICENSE"]+                  , C.specVersionRaw = Left $ C.mkVersion [1,12]+                  }+              , C.genPackageFlags = flags+              , C.condLibrary =+                  let mkLib bi = mempty { C.libBuildInfo = bi }+                  in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $+                     Buildable (CD.libraryDeps (exAvDeps ex))+              , C.condSubLibraries = []+              , C.condForeignLibs = []+              , C.condExecutables =+                  let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable+                      mkExe bi = mempty { C.buildInfo = bi }+                  in map (\(t, deps) -> (t, mkTree deps)) executables+              , C.condTestSuites =+                  let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable+                      mkTest bi = mempty { C.testBuildInfo = bi }+                  in map (\(t, deps) -> (t, mkTree deps)) testSuites+              , C.condBenchmarks  = []+              }+            }+        pkgCheckErrors =+          -- We ignore these warnings because some unit tests test that the+          -- solver allows unknown extensions/languages when the compiler+          -- supports them.+          let ignore = ["Unknown extensions:", "Unknown languages:"]+          in [ err | err <- C.checkPackage (packageDescription package) Nothing+             , not $ any (`isPrefixOf` C.explanation err) ignore ]+    in if null pkgCheckErrors+       then package+       else error $ "invalid GenericPackageDescription for package "+                 ++ display pkgId ++ ": " ++ show pkgCheckErrors+  where+    defaultTopLevelBuildInfo :: C.BuildInfo+    defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }++    defaultLib :: C.Library+    defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] }++    defaultExe :: C.Executable+    defaultExe = mempty { C.modulePath = "Main.hs" }++    defaultTest :: C.TestSuite+    defaultTest = mempty {+        C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"+      }++    -- Split the set of dependencies into the set of dependencies of the library,+    -- the dependencies of the test suites and extensions.+    splitTopLevel :: [ExampleDependency]+                  -> ( [ExampleDependency]+                     , [Extension]+                     , Maybe Language+                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config+                     , [(ExamplePkgName, C.VersionRange)] -- build tools+                     )+    splitTopLevel [] =+        ([], [], Nothing, [], [])+    splitTopLevel (ExBuildToolAny p:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, C.anyVersion):exes)+    splitTopLevel (ExBuildToolFix p v:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pcpkgs, (p, C.thisVersion (mkVersion v)):exes)+    splitTopLevel (ExExt ext:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, ext:exts, lang, pcpkgs, exes)+    splitTopLevel (ExLang lang:deps) =+        case splitTopLevel deps of+            (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes)+            _ -> error "Only 1 Language dependency is supported"+    splitTopLevel (ExPkg pkg:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (other, exts, lang, pkg:pcpkgs, exes)+    splitTopLevel (dep:deps) =+      let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps+      in (dep:other, exts, lang, pcpkgs, exes)++    -- Extract the total set of flags used+    extractFlags :: ExampleDependency -> [ExampleFlagName]+    extractFlags (ExAny _)            = []+    extractFlags (ExFix _ _)          = []+    extractFlags (ExRange _ _ _)      = []+    extractFlags (ExBuildToolAny _)   = []+    extractFlags (ExBuildToolFix _ _) = []+    extractFlags (ExFlagged f a b)    =+        f : concatMap extractFlags (deps a ++ deps b)+      where+        deps :: Dependencies -> [ExampleDependency]+        deps NotBuildable = []+        deps (Buildable ds) = ds+    extractFlags (ExExt _)      = []+    extractFlags (ExLang _)     = []+    extractFlags (ExPkg _)      = []++    -- Convert a tree of BuildInfos into a tree of a specific component type.+    -- 'defaultTopLevel' contains the default values for the component, and+    -- 'mkComponent' creates a component from a 'BuildInfo'.+    mkCondTree :: forall a. Semigroup a =>+                  a -> (C.BuildInfo -> a)+               -> DependencyTree C.BuildInfo+               -> DependencyTree a+    mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) =+        C.CondNode {+            C.condTreeData =+                defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData)+          , C.condTreeConstraints = topConstraints+          , C.condTreeComponents = goComponents topComps+          }+      where+        go :: DependencyTree C.BuildInfo -> DependencyTree a+        go (C.CondNode ctData constraints comps) =+            C.CondNode (mkComponent ctData) constraints (goComponents comps)++        goComponents :: [DependencyComponent C.BuildInfo]+                     -> [DependencyComponent a]+        goComponents comps = [C.CondBranch cond (go t) (go <$> me) | C.CondBranch cond t me <- comps]++    mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo+    mkBuildInfoTree NotBuildable =+      C.CondNode {+             C.condTreeData        = mempty { C.buildable = False }+           , C.condTreeConstraints = []+           , C.condTreeComponents  = []+           }+    mkBuildInfoTree (Buildable deps) =+      let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps+          (directDeps, flaggedDeps) = splitDeps libraryDeps+          bi = mempty {+                  C.otherExtensions = exts+                , C.defaultLanguage = mlang+                , C.buildTools = [ C.LegacyExeDependency n vr+                                 | (n,vr) <- buildTools ]+                , C.pkgconfigDepends = [ C.PkgconfigDependency n' v'+                                       | (n,v) <- pcpkgs+                                       , let n' = C.mkPkgconfigName n+                                       , let v' = C.thisVersion (mkVersion v) ]+              }+      in C.CondNode {+             C.condTreeData        = bi -- Necessary for language extensions+           -- TODO: Arguably, build-tools dependencies should also+           -- effect constraints on conditional tree. But no way to+           -- distinguish between them+           , C.condTreeConstraints = map mkDirect directDeps+           , C.condTreeComponents  = map mkFlagged flaggedDeps+           }++    mkDirect :: (ExamplePkgName, C.VersionRange) -> C.Dependency+    mkDirect (dep, vr) = C.Dependency (C.mkPackageName dep) vr++    mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)+              -> DependencyComponent C.BuildInfo+    mkFlagged (f, a, b) =+        C.CondBranch (C.Var (C.Flag (C.mkFlagName f)))+                     (mkBuildInfoTree a)+                     (Just (mkBuildInfoTree b))++    -- Split a set of dependencies into direct dependencies and flagged+    -- dependencies. A direct dependency is a tuple of the name of package and+    -- its version range meant to be converted to a 'C.Dependency' with+    -- 'mkDirect' for example. A flagged dependency is the set of dependencies+    -- guarded by a flag.+    splitDeps :: [ExampleDependency]+              -> ( [(ExamplePkgName, C.VersionRange)]+                 , [(ExampleFlagName, Dependencies, Dependencies)]+                 )+    splitDeps [] =+      ([], [])+    splitDeps (ExAny p:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.anyVersion):directDeps, flaggedDeps)+    splitDeps (ExFix p v:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, C.thisVersion $ mkVersion v):directDeps, flaggedDeps)+    splitDeps (ExRange p v1 v2:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps)+    splitDeps (ExFlagged f a b:deps) =+      let (directDeps, flaggedDeps) = splitDeps deps+      in (directDeps, (f, a, b):flaggedDeps)+    splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep++    -- custom-setup only supports simple dependencies+    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]+    mkSetupDeps deps =+      let (directDeps, []) = splitDeps deps in map mkDirect directDeps++mkVersion :: ExamplePkgVersion -> C.Version+mkVersion n = C.mkVersion [n, 0, 0]++mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange+mkVersionRange v1 v2 =+    C.intersectVersionRanges (C.orLaterVersion $ mkVersion v1)+                             (C.earlierVersion $ mkVersion v2)++mkFlag :: ExFlag -> C.Flag+mkFlag flag = C.MkFlag {+    C.flagName        = C.mkFlagName $ exFlagName flag+  , C.flagDescription = ""+  , C.flagDefault     = exFlagDefault flag+  , C.flagManual      =+      case exFlagType flag of+        Manual    -> True+        Automatic -> False+  }++mkDefaultFlag :: ExampleFlagName -> C.Flag+mkDefaultFlag flag = C.MkFlag {+    C.flagName        = C.mkFlagName flag+  , C.flagDescription = ""+  , C.flagDefault     = True+  , C.flagManual      = False+  }++exAvPkgId :: ExampleAvailable -> C.PackageIdentifier+exAvPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exAvName ex)+    , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]+    }++exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo+exInstInfo ex = IPI.emptyInstalledPackageInfo {+      IPI.installedUnitId    = C.mkUnitId (exInstHash ex)+    , IPI.sourcePackageId    = exInstPkgId ex+    , IPI.depends            = map C.mkUnitId (exInstBuildAgainst ex)+    }++exInstPkgId :: ExampleInstalled -> C.PackageIdentifier+exInstPkgId ex = C.PackageIdentifier {+      pkgName    = C.mkPackageName (exInstName ex)+    , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]+    }++exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage+exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg++exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex+exInstIdx = C.PackageIndex.fromList . map exInstInfo++exResolve :: ExampleDb+          -- List of extensions supported by the compiler, or Nothing if unknown.+          -> Maybe [Extension]+          -- List of languages supported by the compiler, or Nothing if unknown.+          -> Maybe [Language]+          -> PC.PkgConfigDb+          -> [ExamplePkgName]+          -> Solver+          -> Maybe Int+          -> IndependentGoals+          -> ReorderGoals+          -> AllowBootLibInstalls+          -> EnableBackjumping+          -> Maybe [ExampleVar]+          -> [ExConstraint]+          -> [ExPreference]+          -> EnableAllTests+          -> Progress String String CI.SolverInstallPlan.SolverInstallPlan+exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder+          allowBootLibInstalls enableBj vars constraints prefs enableAllTests+    = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params+  where+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag+    compiler = defaultCompiler { C.compilerInfoExtensions = exts+                               , C.compilerInfoLanguages  = langs+                               }+    (inst, avai) = partitionEithers db+    instIdx      = exInstIdx inst+    avaiIdx      = SourcePackageDb {+                       packageIndex       = exAvIdx avai+                     , packagePreferences = Map.empty+                     }+    enableTests+        | asBool enableAllTests = fmap (\p -> PackageConstraint+                                              (scopeToplevel (C.mkPackageName p))+                                              (PackagePropertyStanzas [TestStanzas]))+                                       (exDbPkgs db)+        | otherwise             = []+    targets'     = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets+    params       =   addConstraints (fmap toConstraint constraints)+                   $ addConstraints (fmap toLpc enableTests)+                   $ addPreferences (fmap toPref prefs)+                   $ setIndependentGoals indepGoals+                   $ setReorderGoals reorder+                   $ setMaxBackjumps mbj+                   $ setAllowBootLibInstalls allowBootLibInstalls+                   $ setEnableBackjumping enableBj+                   $ setGoalOrder goalOrder+                   $ standardInstallPolicy instIdx avaiIdx targets'+    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown++    toConstraint (ExVersionConstraint scope v) =+        toLpc $ PackageConstraint scope (PackagePropertyVersion v)+    toConstraint (ExFlagConstraint scope fn b) =+        toLpc $ PackageConstraint scope (PackagePropertyFlags [(C.mkFlagName fn, b)])++    toPref (ExPkgPref n v)          = PackageVersionPreference (C.mkPackageName n) v+    toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas++    goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)+    goalOrder = (orderFromList . map toVariable) `fmap` vars++    -- Sort elements in the list ahead of elements not in the list. Otherwise,+    -- follow the order in the list.+    orderFromList :: Eq a => [a] -> a -> a -> Ordering+    orderFromList xs =+        comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)++    toVariable :: ExampleVar -> Variable P.QPN+    toVariable (P q pn)        = PackageVar (toQPN q pn)+    toVariable (F q pn fn)     = FlagVar    (toQPN q pn) (C.mkFlagName fn)+    toVariable (S q pn stanza) = StanzaVar  (toQPN q pn) stanza++    toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN+    toQPN q pn = P.Q pp (C.mkPackageName pn)+      where+        pp = case q of+               None           -> P.PackagePath P.DefaultNamespace P.QualToplevel+               Indep x        -> P.PackagePath (P.Independent x) P.QualToplevel+               Setup p        -> P.PackagePath P.DefaultNamespace (P.QualSetup (C.mkPackageName p))+               IndepSetup x p -> P.PackagePath (P.Independent x) (P.QualSetup (C.mkPackageName p))++extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan+                   -> [(ExamplePkgName, ExamplePkgVersion)]+extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList+  where+    confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)+    confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg+    confPkg _                               = Nothing++    srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int)+    srcPkg cpkg =+      let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg)+      in (C.unPackageName pn, head (C.versionNumbers ver))++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Run Progress computation+runProgress :: Progress step e a -> ([step], Either e a)+runProgress = go+  where+    go (Step s p) = let (ss, result) = go p in (s:ss, result)+    go (Fail e)   = ([], Left e)+    go (Done a)   = ([], Right a)
+ tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE RecordWildCards #-}+-- | Utilities for creating HUnit test cases with the solver DSL.+module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (+    SolverTest+  , SolverResult(..)+  , independentGoals+  , allowBootLibInstalls+  , disableBackjumping+  , goalOrder+  , constraints+  , preferences+  , enableAllTests+  , solverSuccess+  , solverFailure+  , anySolverFailure+  , mkTest+  , mkTestExts+  , mkTestLangs+  , mkTestPCDepends+  , mkTestExtLangPC+  , runTest+  ) where++-- test-framework+import Test.Tasty as TF+import Test.Tasty.HUnit (testCase, assertEqual, assertBool)++-- Cabal+import Language.Haskell.Extension (Extension(..), Language(..))++-- cabal-install+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)+import Distribution.Solver.Types.Settings+import Distribution.Client.Dependency (foldProgress)+import Distribution.Client.Dependency.Types+         ( Solver(Modular) )+import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Options++-- | Combinator to turn on --independent-goals behavior, i.e. solve+-- for the goals as if we were solving for each goal independently.+independentGoals :: SolverTest -> SolverTest+independentGoals test = test { testIndepGoals = IndependentGoals True }++allowBootLibInstalls :: SolverTest -> SolverTest+allowBootLibInstalls test =+    test { testAllowBootLibInstalls = AllowBootLibInstalls True }++disableBackjumping :: SolverTest -> SolverTest+disableBackjumping test =+    test { testEnableBackjumping = EnableBackjumping False }++goalOrder :: [ExampleVar] -> SolverTest -> SolverTest+goalOrder order test = test { testGoalOrder = Just order }++constraints :: [ExConstraint] -> SolverTest -> SolverTest+constraints cs test = test { testConstraints = cs }++preferences :: [ExPreference] -> SolverTest -> SolverTest+preferences prefs test = test { testSoftConstraints = prefs }++enableAllTests :: SolverTest -> SolverTest+enableAllTests test = test { testEnableAllTests = EnableAllTests True }++{-------------------------------------------------------------------------------+  Solver tests+-------------------------------------------------------------------------------}++data SolverTest = SolverTest {+    testLabel          :: String+  , testTargets        :: [String]+  , testResult         :: SolverResult+  , testIndepGoals     :: IndependentGoals+  , testAllowBootLibInstalls :: AllowBootLibInstalls+  , testEnableBackjumping :: EnableBackjumping+  , testGoalOrder      :: Maybe [ExampleVar]+  , testConstraints    :: [ExConstraint]+  , testSoftConstraints :: [ExPreference]+  , testDb             :: ExampleDb+  , testSupportedExts  :: Maybe [Extension]+  , testSupportedLangs :: Maybe [Language]+  , testPkgConfigDb    :: PkgConfigDb+  , testEnableAllTests :: EnableAllTests+  }++-- | Expected result of a solver test.+data SolverResult = SolverResult {+    -- | The solver's log should satisfy this predicate. Note that we also print+    -- the log, so evaluating a large log here can cause a space leak.+    resultLogPredicate            :: [String] -> Bool,++    -- | Fails with an error message satisfying the predicate, or succeeds with+    -- the given plan.+    resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]+  }++solverSuccess :: [(String, Int)] -> SolverResult+solverSuccess = SolverResult (const True) . Right++solverFailure :: (String -> Bool) -> SolverResult+solverFailure = SolverResult (const True) . Left++-- | Can be used for test cases where we just want to verify that+-- they fail, but do not care about the error message.+anySolverFailure :: SolverResult+anySolverFailure = solverFailure (const True)++-- | Makes a solver test case, consisting of the following components:+--+--      1. An 'ExampleDb', representing the package database (both+--         installed and remote) we are doing dependency solving over,+--      2. A 'String' name for the test,+--      3. A list '[String]' of package names to solve for+--      4. The expected result, either 'Nothing' if there is no+--         satisfying solution, or a list '[(String, Int)]' of+--         packages to install, at which versions.+--+-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how+-- to construct an 'ExampleDb', as well as definitions of 'db1' etc.+-- in this file.+mkTest :: ExampleDb+       -> String+       -> [String]+       -> SolverResult+       -> SolverTest+mkTest = mkTestExtLangPC Nothing Nothing []++mkTestExts :: [Extension]+           -> ExampleDb+           -> String+           -> [String]+           -> SolverResult+           -> SolverTest+mkTestExts exts = mkTestExtLangPC (Just exts) Nothing []++mkTestLangs :: [Language]+            -> ExampleDb+            -> String+            -> [String]+            -> SolverResult+            -> SolverTest+mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) []++mkTestPCDepends :: [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb++mkTestExtLangPC :: Maybe [Extension]+                -> Maybe [Language]+                -> [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> SolverResult+                -> SolverTest+mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {+    testLabel          = label+  , testTargets        = targets+  , testResult         = result+  , testIndepGoals     = IndependentGoals False+  , testAllowBootLibInstalls = AllowBootLibInstalls False+  , testEnableBackjumping = EnableBackjumping True+  , testGoalOrder      = Nothing+  , testConstraints    = []+  , testSoftConstraints = []+  , testDb             = db+  , testSupportedExts  = exts+  , testSupportedLangs = langs+  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb+  , testEnableAllTests = EnableAllTests False+  }++runTest :: SolverTest -> TF.TestTree+runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->+    testCase testLabel $ do+      let progress = exResolve testDb testSupportedExts+                     testSupportedLangs testPkgConfigDb testTargets+                     Modular Nothing testIndepGoals (ReorderGoals False)+                     testAllowBootLibInstalls testEnableBackjumping testGoalOrder+                     testConstraints testSoftConstraints testEnableAllTests+          printMsg msg = if showSolverLog+                         then putStrLn msg+                         else return ()+          msgs = foldProgress (:) (const []) (const []) progress+      assertBool ("Unexpected solver log:\n" ++ unlines msgs) $+                 resultLogPredicate testResult $ concatMap lines msgs+      result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress+      case result of+        Left  err  -> assertBool ("Unexpected error:\n" ++ err)+                                 (checkErrorMsg testResult err)+        Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))+  where+    toMaybe :: SolverResult -> Maybe [(String, Int)]+    toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan++    checkErrorMsg :: SolverResult -> String -> Bool+    checkErrorMsg result msg =+        case resultErrorMsgPredicateOrPlan result of+          Left f  -> f msg+          Right _ -> False
+ tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs view
@@ -0,0 +1,97 @@+-- | Tests for detecting space leaks in the dependency solver.+module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where++import Test.Tasty (TestTree)++import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils++tests :: [TestTree]+tests = [+      runTest $ basicTest "basic space leak test"+    , runTest $ flagsTest "package with many flags"+    , runTest $ issue2899 "issue #2899"+    ]++-- | This test solves for n packages that each have two versions. There is no+-- solution, because the nth package depends on another package that doesn't fit+-- its version constraint. Backjumping is disabled, so the solver must explore a+-- search tree of size 2^n. It should fail if memory usage is proportional to+-- the size of the tree.+basicTest :: String -> SolverTest+basicTest name =+    disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure+  where+    n :: Int+    n = 18++    pkgs :: ExampleDb+    pkgs = map Right $+           [ exAv "target" 1 [ExAny $ pkgName 1]]+        ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4]+           | i <- [1..n], v <- [2, 3]]+        ++ [exAv (pkgName $ n + 1) 1 []]++    pkgName :: Int -> ExamplePkgName+    pkgName x = "pkg-" ++ show x++-- | This test is similar to 'basicTest', except that it has one package with n+-- flags, flag-1 through flag-n. The solver assigns flags in order, so it+-- doesn't discover the unknown dependencies under flag-n until it has assigned+-- all of the flags. It has to explore the whole search tree.+flagsTest :: String -> SolverTest+flagsTest name =+    disableBackjumping $+    goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure+  where+    n :: Int+    n = 16++    pkgs :: ExampleDb+    pkgs = [Right $ exAv "pkg" 1 $+                [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]++                -- The remaining flags have no effect:+             ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]]+           ]++    flagName :: Int -> ExampleFlagName+    flagName x = "flag-" ++ show x++    orderedFlags :: [ExampleVar]+    orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]]++-- | Test for a space leak caused by sharing of search trees under packages with+-- link choices (issue #2899).+--+-- The goal order is fixed so that the solver chooses setup-dep and then+-- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep+-- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep+-- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n+-- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each+-- dependency has two versions, the solver must try 2^n combinations when+-- backjumping is disabled. These combinations create large search trees under+-- each of the two choices for target-setup.setup-dep. Although the choice to+-- not link is disallowed by the Single Instance Restriction, the solver doesn't+-- know that until it has explored (and evaluated) the whole tree under the+-- choice to link. If the two trees are shared, memory usage spikes.+issue2899 :: String -> SolverTest+issue2899 name =+    disableBackjumping $+    goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure+  where+    n :: Int+    n = 16++    pkgs :: ExampleDb+    pkgs = map Right $+           [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"]+           , exAv "setup-dep" 1 [ExAny $ pkgName 1]]+        ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)]+           | i <- [1..n], v <- [1, 2]]++    pkgName :: Int -> ExamplePkgName+    pkgName x = "pkg-" ++ show x++    goals :: [ExampleVar]+    goals = [P None "setup-dep", P (Setup "target") "setup-dep"]
+ tests/UnitTests/Distribution/Solver/Modular/PSQ.hs view
@@ -0,0 +1,22 @@+module UnitTests.Distribution.Solver.Modular.PSQ (+  tests+  ) where++import Distribution.Solver.Modular.PSQ++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testProperty "splitsAltImplementation" splitsTest+        ]++-- | Original splits implementation+splits' :: PSQ k a -> PSQ k (a, PSQ k a)+splits' xs =+  casePSQ xs+    (PSQ [])+    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))++splitsTest :: [(Int, Int)] -> Bool+splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)
+ tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where++import Control.DeepSeq (NFData, force)+import Control.Monad (foldM)+import Data.Either (lefts)+import Data.Function (on)+import Data.List (groupBy, isInfixOf, nub, nubBy, sort)+import Data.Maybe (isJust)+import GHC.Generics (Generic)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (Monoid)+#endif++import Text.Show.Pretty (parseValue, valToStr)++import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck++import Distribution.Client.Dependency.Types+         ( Solver(..) )+import Distribution.Client.Setup (defaultMaxBackjumps)++import           Distribution.Types.UnqualComponentName++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps+                   ( Component(..), ComponentDep, ComponentDeps )+import           Distribution.Solver.Types.PkgConfigDb+                   (pkgConfigDbFromList)+import           Distribution.Solver.Types.Settings++import UnitTests.Distribution.Solver.Modular.DSL++tests :: [TestTree]+tests = [+      -- This test checks that certain solver parameters do not affect the+      -- existence of a solution. It runs the solver twice, and only sets those+      -- parameters on the second run. The test also applies parameters that+      -- can affect the existence of a solution to both runs.+      testProperty "target order and --reorder-goals do not affect solvability" $+          \(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->+            let r1 = solve' (ReorderGoals False) targets  db+                r2 = solve' reorderGoals         targets2 db+                solve' reorder = solve (EnableBackjumping True) reorder+                                       indepGoals solver+                targets2 = case targetOrder of+                             SameOrder -> targets+                             ReverseOrder -> reverse targets+            in counterexample (showResults r1 r2) $+               noneReachedBackjumpLimit [r1, r2] ==>+               isRight (resultPlan r1) === isRight (resultPlan r2)++    , testProperty+          "solvable without --independent-goals => solvable with --independent-goals" $+          \(SolverTest db targets) reorderGoals solver ->+            let r1 = solve' (IndependentGoals False) targets db+                r2 = solve' (IndependentGoals True)  targets db+                solve' indep = solve (EnableBackjumping True)+                                     reorderGoals indep solver+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) `implies` isRight (resultPlan r2)++    , testProperty "backjumping does not affect solvability" $+          \(SolverTest db targets) reorderGoals indepGoals ->+            let r1 = solve' (EnableBackjumping True)  targets db+                r2 = solve' (EnableBackjumping False) targets db+                solve' enableBj = solve enableBj reorderGoals indepGoals Modular+             in counterexample (showResults r1 r2) $+                noneReachedBackjumpLimit [r1, r2] ==>+                isRight (resultPlan r1) === isRight (resultPlan r2)+    ]+  where+    noneReachedBackjumpLimit :: [Result] -> Bool+    noneReachedBackjumpLimit =+        not . any (\r -> resultPlan r == Left BackjumpLimitReached)++    showResults :: Result -> Result -> String+    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2++    showResult :: Int -> Result -> String+    showResult n result =+        unlines $ ["", "Run " ++ show n ++ ":"]+               ++ resultLog result+               ++ ["result: " ++ show (resultPlan result)]++    implies :: Bool -> Bool -> Bool+    implies x y = not x || y++    isRight :: Either a b -> Bool+    isRight (Right _) = True+    isRight _         = False++solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals+      -> Solver -> [PN] -> TestDb -> Result+solve enableBj reorder indep solver targets (TestDb db) =+  let (lg, result) =+        runProgress $ exResolve db Nothing Nothing+                  (pkgConfigDbFromList [])+                  (map unPN targets)+                  solver+                  -- The backjump limit prevents individual tests from using+                  -- too much time and memory.+                  (Just defaultMaxBackjumps)+                  indep reorder (AllowBootLibInstalls False) enableBj Nothing [] []+                  (EnableAllTests True)++      failure :: String -> Failure+      failure msg+        | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached+        | otherwise                                = OtherFailure+  in Result {+       resultLog = lg+     , resultPlan =+         -- Force the result so that we check for internal errors when we check+         -- for success or failure. See D.C.Dependency.validateSolverResult.+         force $ either (Left . failure) (Right . extractInstallPlan) result+     }++-- | How to modify the order of the input targets.+data TargetOrder = SameOrder | ReverseOrder+  deriving Show++instance Arbitrary TargetOrder where+  arbitrary = elements [SameOrder, ReverseOrder]++  shrink SameOrder = []+  shrink ReverseOrder = [SameOrder]++data Result = Result {+    resultLog :: [String]+  , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)]+  }++data Failure = BackjumpLimitReached | OtherFailure+  deriving (Eq, Generic, Show)++instance NFData Failure++-- | Package name.+newtype PN = PN { unPN :: String }+  deriving (Eq, Ord, Show)++instance Arbitrary PN where+  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])++-- | Package version.+newtype PV = PV { unPV :: Int }+  deriving (Eq, Ord, Show)++instance Arbitrary PV where+  arbitrary = PV <$> elements [1..10]++type TestPackage = Either ExampleInstalled ExampleAvailable++getName :: TestPackage -> PN+getName = PN . either exInstName exAvName++getVersion :: TestPackage -> PV+getVersion = PV . either exInstVersion exAvVersion++data SolverTest = SolverTest {+    testDb :: TestDb+  , testTargets :: [PN]+  }++-- | Pretty-print the test when quickcheck calls 'show'.+instance Show SolverTest where+  show test =+    let str = "SolverTest {testDb = " ++ show (testDb test)+                     ++ ", testTargets = " ++ show (testTargets test) ++ "}"+    in maybe str valToStr $ parseValue str++instance Arbitrary SolverTest where+  arbitrary = do+    db <- arbitrary+    let pkgs = nub $ map getName (unTestDb db)+    Positive n <- arbitrary+    targets <- randomSubset n pkgs+    return (SolverTest db targets)++  shrink test =+         [test { testDb = db } | db <- shrink (testDb test)]+      ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]++-- | Collection of source and installed packages.+newtype TestDb = TestDb { unTestDb :: ExampleDb }+  deriving Show++instance Arbitrary TestDb where+  arbitrary = do+      -- Avoid cyclic dependencies by grouping packages by name and only+      -- allowing each package to depend on packages in the groups before it.+      groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<+                     boundedListOf 10 arbitrary+      db <- foldM nextPkgs (TestDb []) groupedPkgs+      TestDb <$> shuffle (unTestDb db)+    where+      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb+      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs++      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage+      nextPkg db (pn, v) = do+        installed <- arbitrary+        if installed+        then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)+        else Right <$> arbitraryExAv pn v db++  shrink (TestDb pkgs) = map TestDb $ shrink pkgs++arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable+arbitraryExAv pn v db =+    (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db++arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled+arbitraryExInst pn v pkgs = do+  hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']+  numDeps <- min 3 <$> arbitrary+  deps <- randomSubset numDeps pkgs+  return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)++arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])+arbitraryComponentDeps (TestDb []) = return $ CD.fromList []+arbitraryComponentDeps db =+    -- dedupComponentNames removes components with duplicate names, for example,+    -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines+    -- duplicate unnamed components.+    CD.fromList . dedupComponentNames <$>+    boundedListOf 5 (arbitraryComponentDep db)+  where+    dedupComponentNames =+        nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)++    componentName :: Component -> Maybe UnqualComponentName+    componentName ComponentLib        = Nothing+    componentName ComponentSetup      = Nothing+    componentName (ComponentSubLib n) = Just n+    componentName (ComponentFLib   n) = Just n+    componentName (ComponentExe    n) = Just n+    componentName (ComponentTest   n) = Just n+    componentName (ComponentBench  n) = Just n++arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])+arbitraryComponentDep db = do+  comp <- arbitrary+  deps <- case comp of+            ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)+            _              -> boundedListOf 5 (arbitraryExDep db NonSetupDep)+  return (comp, deps)++-- | Location of an 'ExampleDependency'. It determines which values are valid.+data ExDepLocation = SetupDep | NonSetupDep++arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency+arbitraryExDep db@(TestDb pkgs) level =+  let flag = ExFlagged <$> arbitraryFlagName+                       <*> arbitraryDeps db+                       <*> arbitraryDeps db+      other =+          -- Package checks require dependencies on "base" to have bounds.+        let notBase = filter ((/= PN "base") . getName) pkgs+        in  [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]+         ++ [+              -- existing version+              let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)+              in fixed <$> elements pkgs++              -- random version of an existing package+            , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)+            ]+  in oneof $+      case level of+        NonSetupDep -> flag : other+        SetupDep -> other++arbitraryDeps :: TestDb -> Gen Dependencies+arbitraryDeps db = frequency+    [ (1, return NotBuildable)+    , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep))+    ]++arbitraryFlagName :: Gen String+arbitraryFlagName = (:[]) <$> elements ['A'..'E']++instance Arbitrary ReorderGoals where+  arbitrary = ReorderGoals <$> arbitrary++  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]++instance Arbitrary IndependentGoals where+  arbitrary = IndependentGoals <$> arbitrary++  shrink (IndependentGoals indep) = [IndependentGoals False | indep]++instance Arbitrary Solver where+  arbitrary = return Modular++  shrink Modular = []++instance Arbitrary UnqualComponentName where+  arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC"++instance Arbitrary Component where+  arbitrary = oneof [ return ComponentLib+                    , ComponentSubLib <$> arbitrary+                    , ComponentExe <$> arbitrary+                    , ComponentFLib <$> arbitrary+                    , ComponentTest <$> arbitrary+                    , ComponentBench <$> arbitrary+                    , return ComponentSetup+                    ]++  shrink ComponentLib = []+  shrink _ = [ComponentLib]++instance Arbitrary ExampleInstalled where+  arbitrary = error "arbitrary not implemented: ExampleInstalled"++  shrink ei = [ ei { exInstBuildAgainst = deps }+              | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]++instance Arbitrary ExampleAvailable where+  arbitrary = error "arbitrary not implemented: ExampleAvailable"++  shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]++instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where+  arbitrary = error "arbitrary not implemented: ComponentDeps"++  shrink = map CD.fromList . shrink . CD.toList++instance Arbitrary ExampleDependency where+  arbitrary = error "arbitrary not implemented: ExampleDependency"++  shrink (ExAny _) = []+  shrink (ExFix "base" _) = [] -- preserve bounds on base+  shrink (ExFix pn _) = [ExAny pn]+  shrink (ExFlagged flag th el) =+         deps th ++ deps el+      ++ [ExFlagged flag th' el | th' <- shrink th]+      ++ [ExFlagged flag th el' | el' <- shrink el]+    where+      deps NotBuildable = []+      deps (Buildable ds) = ds+  shrink dep = error $ "Dependency not handled: " ++ show dep++instance Arbitrary Dependencies where+  arbitrary = error "arbitrary not implemented: Dependencies"++  shrink NotBuildable = [Buildable []]+  shrink (Buildable deps) = map Buildable (shrink deps)++randomSubset :: Int -> [a] -> Gen [a]+randomSubset n xs = take n <$> shuffle xs++boundedListOf :: Int -> Gen a -> Gen [a]+boundedListOf n gen = take n <$> listOf gen++-- | Generates lists with average length less than 1.+smallListOf :: Gen a -> Gen [a]+smallListOf gen =+    frequency [ (fr, vectorOf n gen)+              | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
+ tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module UnitTests.Distribution.Solver.Modular.RetryLog (+  tests+  ) where++import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Types.Progress++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck+         ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===))++type Log a = Progress a String String++tests :: [TestTree]+tests = [+    testProperty "'toProgress . fromProgress' is identity" $ \p ->+        toProgress (fromProgress p) === (p :: Log Int)++  , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $+        let mapFailureProgress f = foldProgress Step (Fail . f) Done+        in \(Blind f) p ->+               toProgress (mapFailure f (fromProgress p))+               === mapFailureProgress (f :: String -> Int) (p :: Log Int)++  , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $+      \p (Blind f) ->+        toProgress (retry (fromProgress p) (fromProgress . f))+        === (foldProgress Step f Done (p :: Log Int) :: Log Int)++  , testProperty "failWith" $ \step failure ->+        toProgress (failWith step failure)+        === (Step step (Fail failure) :: Log Int)++  , testProperty "succeedWith" $ \step success ->+        toProgress (succeedWith step success)+        === (Step step (Done success) :: Log Int)++  , testProperty "continueWith" $ \step p ->+        toProgress (continueWith step (fromProgress p))+        === (Step step p :: Log Int)++  , testCase "tryWith with failure" $+        let failure = Fail "Error"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s failure)))+           @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)++  , testCase "tryWith with success" $+        let done = Done "Done"+            s = Step Success+        in toProgress (tryWith Success $ fromProgress (s (s done)))+           @?= (s (Step Enter (s (s done))) :: Log Message)+  ]++instance (Arbitrary step, Arbitrary fail, Arbitrary done)+    => Arbitrary (Progress step fail done) where+  arbitrary = do+    steps <- listOf arbitrary+    end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary]+    return $ foldr Step end steps++deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)++deriving instance (Show step, Show fail, Show done)+    => Show (Progress step fail done)++deriving instance Eq Message+deriving instance Show Message
+ tests/UnitTests/Distribution/Solver/Modular/Solver.hs view
@@ -0,0 +1,1231 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This is a set of unit tests for the dependency solver,+-- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL")+-- to more conveniently create package databases to run the solver tests on.+module UnitTests.Distribution.Solver.Modular.Solver (tests)+       where++-- base+import Data.List (isInfixOf)++import qualified Distribution.Version as V++-- test-framework+import Test.Tasty as TF++-- Cabal+import Language.Haskell.Extension ( Extension(..)+                                  , KnownExtension(..), Language(..))++-- cabal-install+import Distribution.Solver.Types.Flag+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.PackagePath+import UnitTests.Distribution.Solver.Modular.DSL+import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils++tests :: [TF.TestTree]+tests = [+      testGroup "Simple dependencies" [+          runTest $         mkTest db1 "alreadyInstalled"   ["A"]      (solverSuccess [])+        , runTest $         mkTest db1 "installLatest"      ["B"]      (solverSuccess [("B", 2)])+        , runTest $         mkTest db1 "simpleDep1"         ["C"]      (solverSuccess [("B", 1), ("C", 1)])+        , runTest $         mkTest db1 "simpleDep2"         ["D"]      (solverSuccess [("B", 2), ("D", 1)])+        , runTest $         mkTest db1 "failTwoVersions"    ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db1 "indepTwoVersions"   ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)])+        , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)])+        , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db1 "buildDepAgainstOld" ["F"]      (solverSuccess [("B", 1), ("E", 1), ("F", 1)])+        , runTest $         mkTest db1 "buildDepAgainstNew" ["G"]      (solverSuccess [("B", 2), ("E", 1), ("G", 1)])+        , runTest $ indep $ mkTest db1 "multipleInstances"  ["F", "G"] anySolverFailure+        , runTest $         mkTest db21 "unknownPackage1"   ["A"]      (solverSuccess [("A", 1), ("B", 1)])+        , runTest $         mkTest db22 "unknownPackage2"   ["A"]      (solverFailure (isInfixOf "unknown package: C"))+        , runTest $         mkTest db23 "unknownPackage3"   ["A"]      (solverFailure (isInfixOf "unknown package: B"))+        ]+    , testGroup "Flagged dependencies" [+          runTest $         mkTest db3 "forceFlagOn"  ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $         mkTest db3 "forceFlagOff" ["D"]      (solverSuccess [("A", 2), ("B", 1), ("D", 1)])+        , runTest $ indep $ mkTest db3 "linkFlags1"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db4 "linkFlags2"   ["C", "D"] anySolverFailure+        , runTest $ indep $ mkTest db18 "linkFlags3"  ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])+        ]+    , testGroup "Manual flags" [+          runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $+          solverSuccess [("pkg", 1), ("true-dep", 1)]++        , let checkFullLog =+                  any $ isInfixOf "rejecting: pkg-1.0.0:-flag (manual flag can only be changed explicitly)"+          in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $+             mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $+             -- TODO: We should check the summarized log instead of the full log+             -- for the manual flags error message, but it currently only+             -- appears in the full log.+             SolverResult checkFullLog (Left $ const True)++        , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False]+          in runTest $ constraints cs $+             mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $+             solverSuccess [("false-dep", 1), ("pkg", 1)]+        ]+    , testGroup "Qualified manual flag constraints" [+          let name = "Top-level flag constraint does not constrain setup dep's flag"+              cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ]++        , let name = "Solver can toggle setup dep's flag to match top-level constraint"+              cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False+                   , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ]++        , let name = "User can constrain flags separately with qualified constraints"+              cs = [ ExFlagConstraint (ScopeQualified QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]+          in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("B", 2)+                           , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ]++          -- Regression test for #4299+        , let name = "Solver can link deps when only one has constrained manual flag"+              cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]+          in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $+             solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ]++        , let name = "Solver cannot link deps that have conflicting manual flag constraints"+              cs = [ ExFlagConstraint (ScopeQualified QualToplevel    "B") "flag" True+                   , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]+              failureReason = "(constraint from unknown source requires opposite flag selection)"+              checkFullLog lns =+                  all (\msg -> any (msg `isInfixOf`) lns)+                  [ "rejecting: B-1.0.0:-flag "         ++ failureReason+                  , "rejecting: A:setup.B-1.0.0:+flag " ++ failureReason ]+          in runTest $ constraints cs $+             mkTest dbLinkedSetupDepWithManualFlag name ["A"] $+             SolverResult checkFullLog (Left $ const True)+        ]+    , testGroup "Stanzas" [+          runTest $         enableAllTests $ mkTest db5 "simpleTest1" ["C"]      (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest2" ["D"]      anySolverFailure+        , runTest $         enableAllTests $ mkTest db5 "simpleTest3" ["E"]      (solverSuccess [("A", 1), ("E", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest4" ["F"]      anySolverFailure -- TODO+        , runTest $         enableAllTests $ mkTest db5 "simpleTest5" ["G"]      (solverSuccess [("A", 2), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure+        , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])+        , runTest $         enableAllTests $ mkTest db6 "depsWithTests1" ["C"]      (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])+        ]+    , testGroup "Setup dependencies" [+          runTest $         mkTest db7  "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])+        , runTest $         mkTest db7  "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)])+        , runTest $         mkTest db7  "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)])+        , runTest $         mkTest db7  "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)])+        , runTest $         mkTest db7  "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)])+        , runTest $         mkTest db8  "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])+        , runTest $         mkTest db9  "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])+        , runTest $         mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])+        , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])+        ]+    , testGroup "Base shim" [+          runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)])+        , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure+        , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)])+        ]+    , testGroup "Base" [+          runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $+                      solverFailure (isInfixOf "only already installed instances can be used")+        , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $+                      solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]+        ]+    , testGroup "Cycles" [+          runTest $ mkTest db14 "simpleCycle1"          ["A"]      anySolverFailure+        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] anySolverFailure+        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (solverSuccess [("C", 1), ("E", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      anySolverFailure+        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (solverSuccess [("C", 2), ("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (solverSuccess [("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (solverSuccess [("C", 2), ("D", 1), ("E", 1)])+        , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"+        ]+    , testGroup "Extensions" [+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)])+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure+        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)])+        ]+    , testGroup "Languages" [+          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)])+        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure+        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)])+        ]+     , testGroup "Qualified Package Constraints" [+          runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $+          solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]++        , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ]+          in runTest $ constraints cs $+             mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $+             solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]++        , let cs = [ ExVersionConstraint (ScopeQualified QualToplevel    "D") $ mkVersionRange 1 4+                   , ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7+                   ]+          in runTest $ constraints cs $+             mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $+             solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]++        , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ]+          in runTest $ constraints cs $+             mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $+             solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)]+        ]+     , testGroup "Package Preferences" [+          runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2+                                , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])+        , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1+                                , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])+        ]+     , testGroup "Stanza Preferences" [+          runTest $+          mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $+          solverSuccess [("pkg", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $+          solverSuccess [("pkg", 1), ("test-dep", 1)]++        , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $+          mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $+          solverSuccess [("pkg", 1)]+        ]+     , testGroup "Buildable Field" [+          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")+        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))+        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))+        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])+        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])+         ]+    , testGroup "Pkg-config dependencies" [+          runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])+        ]+    , testGroup "Independent goals" [+          runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])+        , runTest $ testIndepGoals2 "indepGoals2"+        , runTest $ testIndepGoals3 "indepGoals3"+        , runTest $ testIndepGoals4 "indepGoals4"+        , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder+        , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder+        ]+      -- Tests designed for the backjumping blog post+    , testGroup "Backjumping" [+          runTest $         mkTest dbBJ1a "bj1a" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1b "bj1b" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ1c "bj1c" ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ2  "bj2"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ3  "bj3"  ["A"]      (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)])+        , runTest $         mkTest dbBJ4  "bj4"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $         mkTest dbBJ5  "bj5"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("D", 1)])+        , runTest $         mkTest dbBJ6  "bj6"  ["A"]      (solverSuccess [("A", 1), ("B",  1)])+        , runTest $         mkTest dbBJ7  "bj7"  ["A"]      (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        , runTest $ indep $ mkTest dbBJ8  "bj8"  ["A", "B"] (solverSuccess [("A", 1), ("B",  1), ("C", 1)])+        ]+    -- Build-tools dependencies+    , testGroup "build-tools" [+          runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])+        , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)])+        , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])+        , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])+        , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])+        , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])+        ]+      -- Tests for the contents of the solver's log+    , testGroup "Solver log" [+          -- See issue #3203. The solver should only choose a version for A once.+          runTest $+              let db = [Right $ exAv "A" 1 []]++                  p :: [String] -> Bool+                  p lg =    elem "targets: A" lg+                         && length (filter ("trying: A" `isInfixOf`) lg) == 1+              in mkTest db "deduplicate targets" ["A", "A"] $+                 SolverResult p $ Right [("A", 1)]+        , runTest $+              let db = [Right $ exAv "A" 1 [ExAny "B"]]+                  msg = "After searching the rest of the dependency tree exhaustively, "+                     ++ "these were the goals I've had most trouble fulfilling: A, B"+              in mkTest db "exhaustive search failure message" ["A"] $+                 solverFailure (isInfixOf msg)+        ]+    ]+  where+    indep           = independentGoals+    mkvrThis        = V.thisVersion . makeV+    mkvrOrEarlier   = V.orEarlierVersion . makeV+    makeV v         = V.mkVersion [v,0,0]++data GoalOrder = FixedGoalOrder | DefaultGoalOrder++{-------------------------------------------------------------------------------+  Specific example database for the tests+-------------------------------------------------------------------------------}++db1 :: ExampleDb+db1 =+    let a = exInst "A" 1 "A-1" []+    in [ Left a+       , Right $ exAv "B" 1 [ExAny "A"]+       , Right $ exAv "B" 2 [ExAny "A"]+       , Right $ exAv "C" 1 [ExFix "B" 1]+       , Right $ exAv "D" 1 [ExFix "B" 2]+       , Right $ exAv "E" 1 [ExAny "B"]+       , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]+       , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]+       , Right $ exAv "Z" 1 []+       ]++-- In this example, we _can_ install C and D as independent goals, but we have+-- to pick two diferent versions for B (arbitrarily)+db2 :: ExampleDb+db2 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1]+  , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2]+  ]++db3 :: ExampleDb+db3 = [+     Right $ exAv "A" 1 []+   , Right $ exAv "A" 2 []+   , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]]+   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+   , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]+   ]++-- | Like db3, but the flag picks a different package rather than a+-- different package version+--+-- In db3 we cannot install C and D as independent goals because:+--+-- * The multiple instance restriction says C and D _must_ share B+-- * Since C relies on A-1, C needs B to be compiled with flagB on+-- * Since D relies on A-2, D needs B to be compiled with flagB off+-- * Hence C and D have incompatible requirements on B's flags.+--+-- However, _even_ if we don't check explicitly that we pick the same flag+-- assignment for 0.B and 1.B, we will still detect the problem because+-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to+-- 1.A and therefore we cannot link 0.B to 1.B.+--+-- In db4 the situation however is trickier. We again cannot install+-- packages C and D as independent goals because:+--+-- * As above, the multiple instance restriction says that C and D _must_ share B+-- * Since C relies on Ax-2, it requires B to be compiled with flagB off+-- * Since D relies on Ay-2, it requires B to be compiled with flagB on+-- * Hence C and D have incompatible requirements on B's flags.+--+-- But now this requirement is more indirect. If we only check dependencies+-- we don't see the problem:+--+-- * We link 0.B to 1.B+-- * 0.B relies on Ay-1+-- * 1.B relies on Ax-1+--+-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since+-- we only ever assign to one of these, these constraints are never broken.+db4 :: ExampleDb+db4 = [+     Right $ exAv "Ax" 1 []+   , Right $ exAv "Ax" 2 []+   , Right $ exAv "Ay" 1 []+   , Right $ exAv "Ay" 2 []+   , Right $ exAv "B"  1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]+   , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]+   , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]+   ]++-- | Simple database containing one package with a manual flag.+dbManualFlags :: ExampleDb+dbManualFlags = [+    Right $ declareFlags [ExFlag "flag" True Manual] $+        exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]]+  , Right $ exAv "true-dep"  1 []+  , Right $ exAv "false-dep" 1 []+  ]++-- | Database containing a setup dependency with a manual flag. A's library and+-- setup script depend on two different versions of B. B's manual flag can be+-- set to different values in the two places where it is used.+dbSetupDepWithManualFlag :: ExampleDb+dbSetupDepWithManualFlag =+  let bFlags = [ExFlag "flag" True Manual]+  in [+      Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2]+    , Right $ declareFlags bFlags $+          exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]+                                       [ExAny "b-1-false-dep"]]+    , Right $ declareFlags bFlags $+          exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"]+                                       [ExAny "b-2-false-dep"]]+    , Right $ exAv "b-1-true-dep"  1 []+    , Right $ exAv "b-1-false-dep" 1 []+    , Right $ exAv "b-2-true-dep"  1 []+    , Right $ exAv "b-2-false-dep" 1 []+    ]++-- | A database similar to 'dbSetupDepWithManualFlag', except that the library+-- and setup script both depend on B-1. B must be linked because of the Single+-- Instance Restriction, and its flag can only have one value.+dbLinkedSetupDepWithManualFlag :: ExampleDb+dbLinkedSetupDepWithManualFlag = [+    Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1]+  , Right $ declareFlags [ExFlag "flag" True Manual] $+        exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]+                                     [ExAny "b-1-false-dep"]]+  , Right $ exAv "b-1-true-dep"  1 []+  , Right $ exAv "b-1-false-dep" 1 []+  ]++-- | Some tests involving testsuites+--+-- Note that in this test framework test suites are always enabled; if you+-- want to test without test suites just set up a test database without+-- test suites.+--+-- * C depends on A (through its test suite)+-- * D depends on B-2 (through its test suite), but B-2 is unavailable+-- * E depends on A-1 directly and on A through its test suite. We prefer+--     to use A-1 for the test suite in this case.+-- * F depends on A-1 directly and on A-2 through its test suite. In this+--     case we currently fail to install F, although strictly speaking+--     test suites should be considered independent goals.+-- * G is like E, but for version A-2. This means that if we cannot install+--     E and G together, unless we regard them as independent goals.+db5 :: ExampleDb+db5 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]+  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]+  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]+  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]+  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]+  ]++-- Now the _dependencies_ have test suites+--+-- * Installing C is a simple example. C wants version 1 of A, but depends on+--   B, and B's testsuite depends on an any version of A. In this case we prefer+--   to link (if we don't regard test suites as independent goals then of course+--   linking here doesn't even come into it).+-- * Installing [C, D] means that we prefer to link B -- depending on how we+--   set things up, this means that we should also link their test suites.+db6 :: ExampleDb+db6 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]+  , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]+  , Right $ exAv "D" 1 [ExAny "B"]+  ]++-- Packages with setup dependencies+--+-- Install..+-- * B: Simple example, just make sure setup deps are taken into account at all+-- * C: Both the package and the setup script depend on any version of A.+--      In this case we prefer to link+-- * D: Variation on C.1 where the package requires a specific (not latest)+--      version but the setup dependency is not fixed. Again, we prefer to+--      link (picking the older version)+-- * E: Variation on C.2 with the setup dependency the more inflexible.+--      Currently, in this case we do not see the opportunity to link because+--      we consider setup dependencies after normal dependencies; we will+--      pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick+--      A.1 instead. This isn't so easy to fix (if we want to fix it at all);+--      in particular, considering setup dependencies _before_ other deps is+--      not an improvement, because in general we would prefer to link setup+--      setups to package deps, rather than the other way around. (For example,+--      if we change this ordering then the test for D would start to install+--      two versions of A).+-- * F: The package and the setup script depend on different versions of A.+--      This will only work if setup dependencies are considered independent.+db7 :: ExampleDb+db7 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "B" 1 []            `withSetupDeps` [ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "A"  ] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"  ]+  , Right $ exAv "E" 1 [ExAny "A"  ] `withSetupDeps` [ExFix "A" 1]+  , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+  ]++-- If we install C and D together (not as independent goals), we need to build+-- both B.1 and B.2, both of which depend on A.+db8 :: ExampleDb+db8 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "B" 2 [ExAny "A"]+  , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]+  , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2]+  ]++-- Extended version of `db8` so that we have nested setup dependencies+db9 :: ExampleDb+db9 = db8 ++ [+    Right $ exAv "E" 1 [ExAny "C"]+  , Right $ exAv "E" 2 [ExAny "D"]+  , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]+  , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]+  ]++-- Multiple already-installed packages with inter-dependencies, and one package+-- (C) that depends on package A-1 for its setup script and package A-2 as a+-- library dependency.+db10 :: ExampleDb+db10 =+  let rts         = exInst "rts"         1 "rts-inst"         []+      ghc_prim    = exInst "ghc-prim"    1 "ghc-prim-inst"    [rts]+      base        = exInst "base"        1 "base-inst"        [rts, ghc_prim]+      a1          = exInst "A"           1 "A1-inst"          [base]+      a2          = exInst "A"           2 "A2-inst"          [base]+  in [+      Left rts+    , Left ghc_prim+    , Left base+    , Left a1+    , Left a2+    , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]+    ]++-- | This database tests that a package's setup dependencies are correctly+-- linked when the package is linked. See pull request #3268.+--+-- When A and B are installed as independent goals, their dependencies on C must+-- be linked, due to the single instance restriction. Since C depends on D, 0.D+-- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D+-- and 1.C-setup.D must be linked. However, D's two link groups must remain+-- independent. The solver should be able to choose D-1 for C's library and D-2+-- for C's setup script.+dbSetupDeps :: ExampleDb+dbSetupDeps = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  ]++-- | Tests for dealing with base shims+db11 :: ExampleDb+db11 =+  let base3 = exInst "base" 3 "base-3-inst" [base4]+      base4 = exInst "base" 4 "base-4-inst" []+  in [+      Left base3+    , Left base4+    , Right $ exAv "A" 1 [ExFix "base" 3]+    ]++-- | Slightly more realistic version of db11 where base-3 depends on syb+-- This means that if a package depends on base-3 and on syb, then they MUST+-- share the version of syb+--+-- * Package A relies on base-3 (which relies on base-4)+-- * Package B relies on base-4+-- * Package C relies on both A and B+-- * Package D relies on base-3 and on syb-2, which is not possible because+--     base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier)+-- * Package E relies on base-4 and on syb-2, which is fine.+db12 :: ExampleDb+db12 =+  let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]+      base4 = exInst "base" 4 "base-4-inst" []+      syb1  = exInst "syb" 1 "syb-1-inst" [base4]+  in [+      Left base3+    , Left base4+    , Left syb1+    , Right $ exAv "syb" 2 [ExFix "base" 4]+    , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]+    , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]+    , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+    , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]+    , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]+    ]++dbBase :: ExampleDb+dbBase = [+      Right $ exAv "base" 1+              [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"]+    , Right $ exAv "ghc-prim" 1 []+    , Right $ exAv "integer-simple" 1 []+    , Right $ exAv "integer-gmp" 1 []+    ]++db13 :: ExampleDb+db13 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "A" 3 []+  ]++-- | A, B, and C have three different dependencies on D that can be set to+-- different versions with qualified constraints. Each version of D can only+-- be depended upon by one version of A, B, or C, so that the versions of A, B,+-- and C in the install plan indicate which version of D was chosen for each+-- dependency. The one-to-one correspondence between versions of A, B, and C and+-- versions of D also prevents linking, which would complicate the solver's+-- behavior.+dbConstraints :: ExampleDb+dbConstraints =+    [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]]+ ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]]+ ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]]+ ++ [Right $ exAv "D" v [] | v <- [1..9]]++dbStanzaPreferences1 :: ExampleDb+dbStanzaPreferences1 = [+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"]+  , Right $ exAv "test-dep" 1 []+  ]++dbStanzaPreferences2 :: ExampleDb+dbStanzaPreferences2 = [+    Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"]+  ]++-- | Database with some cycles+--+-- * Simplest non-trivial cycle: A -> B and B -> A+-- * There is a cycle C -> D -> C, but it can be broken by picking the+--   right flag assignment.+db14 :: ExampleDb+db14 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]]+  , Right $ exAv "D" 1 [ExAny "C"]+  , Right $ exAv "E" 1 []+  ]++-- | Cycles through setup dependencies+--+-- The first cycle is unsolvable: package A has a setup dependency on B,+-- B has a regular dependency on A, and we only have a single version available+-- for both.+--+-- The second cycle can be broken by picking different versions: package C-2.0+-- has a setup dependency on D, and D has a regular dependency on C-*. However,+-- version C-1.0 is already available (perhaps it didn't have this setup dep).+-- Thus, we should be able to break this cycle even if we are installing package+-- E, which explictly depends on C-2.0.+db15 :: ExampleDb+db15 = [+    -- First example (real cycle, no solution)+    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]+  , Right $ exAv   "B" 1            [ExAny "A"]+    -- Second example (cycle can be broken by picking versions carefully)+  , Left  $ exInst "C" 1 "C-1-inst" []+  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]+  , Right $ exAv   "D" 1            [ExAny "C"  ]+  , Right $ exAv   "E" 1            [ExFix "C" 2]+  ]++-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack+-- as soon as it chooses the last package in the cycle, to avoid searching parts+-- of the tree that have no solution. Since there is no way to break the cycle,+-- it should fail with an error message describing the cycle.+testCyclicDependencyErrorMessages :: String -> SolverTest+testCyclicDependencyErrorMessages name =+    goalOrder goals $+    mkTest db name ["pkg-A"] $+    SolverResult checkFullLog $ Left checkSummarizedLog+  where+    db :: ExampleDb+    db = [+        Right $ exAv "pkg-A" 1 [ExAny "pkg-B"]+      , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"]+      , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"]+      , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"]+      , Right $ exAv "pkg-E" 1 []+      ]++    -- The solver should backtrack as soon as pkg-A, pkg-B, and pkg-C form a+    -- cycle. It shouldn't try pkg-D or pkg-E.+    checkFullLog :: [String] -> Bool+    checkFullLog =+        not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l)++    checkSummarizedLog :: String -> Bool+    checkSummarizedLog =+        isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"++    -- Solve for pkg-D and pkg-E last.+    goals :: [ExampleVar]+    goals = [P None ("pkg-" ++ [c]) | c <- ['A'..'E']]++-- | Check that the solver can backtrack after encountering the SIR (issue #2843)+--+-- When A and B are installed as independent goals, the single instance+-- restriction prevents B from depending on C.  This database tests that the+-- solver can backtrack after encountering the single instance restriction and+-- choose the only valid flag assignment (-flagA +flagB):+--+-- > flagA flagB  B depends on+-- >  On    _     C-*+-- >  Off   On    E-*               <-- only valid flag assignment+-- >  Off   Off   D-2.0, C-*+--+-- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D,+-- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have+-- C in the transitive closure of B's dependencies, because that would mean we+-- would need two instances of C: one built against D-1.0 and one built against+-- D-2.0.+db16 :: ExampleDb+db16 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ ExFix "D" 2+                       , exFlagged "flagA"+                             [ExAny "C"]+                             [exFlagged "flagB"+                                 [ExAny "E"]+                                 [ExAny "C"]]]+  , Right $ exAv "C" 1 [ExAny "D"]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  ]++-- | This test checks that when the solver discovers a constraint on a+-- package's version after choosing to link that package, it can backtrack to+-- try alternative versions for the linked-to package. See pull request #3327.+--+-- When A and B are installed as independent goals, their dependencies on C+-- must be linked. Since C depends on D, A and B's dependencies on D must also+-- be linked. This test fixes the goal order so that the solver chooses D-2 for+-- both 0.D and 1.D before it encounters the test suites' constraints. The+-- solver must backtrack to try D-1 for both 0.D and 1.D.+testIndepGoals2 :: String -> SolverTest+testIndepGoals2 name =+    goalOrder goals $ independentGoals $+    enableAllTests $ mkTest db name ["A", "B"] $+    solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]+      , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1]+      , Right $ exAv "C" 1 [ExAny "D"]+      , Right $ exAv "D" 1 []+      , Right $ exAv "D" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "A"+      , P (Indep 0) "C"+      , P (Indep 0) "D"+      , P (Indep 1) "B"+      , P (Indep 1) "C"+      , P (Indep 1) "D"+      , S (Indep 1) "B" TestStanzas+      , S (Indep 0) "A" TestStanzas+      ]++-- | Issue #2834+-- When both A and B are installed as independent goals, their dependencies on+-- C must be linked. The only combination of C's flags that is consistent with+-- A and B's dependencies on D is -flagA +flagB. This database tests that the+-- solver can backtrack to find the right combination of flags (requiring F, but+-- not E or G) and apply it to both 0.C and 1.C.+--+-- > flagA flagB  C depends on+-- >  On    _     D-1, E-*+-- >  Off   On    F-*        <-- Only valid choice+-- >  Off   Off   D-2, G-*+--+-- The single instance restriction means we cannot have one instance of C+-- built against D-1 and one instance built against D-2; since A depends on+-- D-1, and B depends on C-2, it is therefore important that C cannot depend+-- on any version of D.+db18 :: ExampleDb+db18 = [+    Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]+  , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]+  , Right $ exAv "C" 1 [exFlagged "flagA"+                           [ExFix "D" 1, ExAny "E"]+                           [exFlagged "flagB"+                               [ExAny "F"]+                               [ExFix "D" 2, ExAny "G"]]]+  , Right $ exAv "D" 1 []+  , Right $ exAv "D" 2 []+  , Right $ exAv "E" 1 []+  , Right $ exAv "F" 1 []+  , Right $ exAv "G" 1 []+  ]++-- | Tricky test case with independent goals (issue #2842)+--+-- Suppose we are installing D, E, and F as independent goals:+--+-- * D depends on A-* and C-1, requiring A-1 to be built against C-1+-- * E depends on B-* and C-2, requiring B-1 to be built against C-2+-- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built+--     against the same version of C, violating the single instance restriction.+--+-- We can visualize this DB as:+--+-- >    C-1   C-2+-- >    /|\   /|\+-- >   / | \ / | \+-- >  /  |  X  |  \+-- > |   | / \ |   |+-- > |   |/   \|   |+-- > |   +     +   |+-- > |   |     |   |+-- > |   A     B   |+-- >  \  |\   /|  /+-- >   \ | \ / | /+-- >    \|  V  |/+-- >     D  F  E+testIndepGoals3 :: String -> SolverTest+testIndepGoals3 name =+    goalOrder goals $ independentGoals $+    mkTest db name ["D", "E", "F"] anySolverFailure+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExAny "C"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1]+      , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2]+      , Right $ exAv "F" 1 [ExAny "A", ExAny "B"]+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "D"+      , P (Indep 0) "C"+      , P (Indep 0) "A"+      , P (Indep 1) "E"+      , P (Indep 1) "C"+      , P (Indep 1) "B"+      , P (Indep 2) "F"+      , P (Indep 2) "B"+      , P (Indep 2) "C"+      , P (Indep 2) "A"+      ]++-- | This test checks that the solver correctly backjumps when dependencies+-- of linked packages are not linked. It is an example where the conflict set+-- from enforcing the single instance restriction is not sufficient. See pull+-- request #3327.+--+-- When A, B, and C are installed as independent goals with the specified goal+-- order, the first choice that the solver makes for E is 0.E-2. Then, when it+-- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally,+-- the solver discovers C's test's constraint on E. It must backtrack to try+-- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead+-- to a solution, because 0.E's version is constrained by A and cannot be+-- changed.+testIndepGoals4 :: String -> SolverTest+testIndepGoals4 name =+    goalOrder goals $ independentGoals $+    enableAllTests $ mkTest db name ["A", "B", "C"] $+    solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)]+  where+    db :: ExampleDb+    db = [+        Right $ exAv "A" 1 [ExFix "E" 2]+      , Right $ exAv "B" 1 [ExAny "D"]+      , Right $ exAv "C" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "E" 1]+      , Right $ exAv "D" 1 [ExAny "E"]+      , Right $ exAv "E" 1 []+      , Right $ exAv "E" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "A"+      , P (Indep 0) "E"+      , P (Indep 1) "B"+      , P (Indep 1) "D"+      , P (Indep 1) "E"+      , P (Indep 2) "C"+      , P (Indep 2) "D"+      , P (Indep 2) "E"+      , S (Indep 2) "C" TestStanzas+      ]++-- | Test the trace messages that we get when a package refers to an unknown pkg+--+-- TODO: Currently we don't actually test the trace messages, and this particular+-- test still suceeds. The trace can only be verified by hand.+db21 :: ExampleDb+db21 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown+  , Right $ exAv "B" 1 []+  ]++-- | A variant of 'db21', which actually fails.+db22 :: ExampleDb+db22 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "A" 2 [ExAny "C"]+  ]++-- | Another test for the unknown package message.  This database tests that+-- filtering out redundant conflict set messages in the solver log doesn't+-- interfere with generating a message about a missing package (part of issue+-- #3617). The conflict set for the missing package is {A, B}. That conflict set+-- is propagated up the tree to the level of A. Since the conflict set is the+-- same at both levels, the solver only keeps one of the backjumping messages.+db23 :: ExampleDb+db23 = [+    Right $ exAv "A" 1 [ExAny "B"]+  ]++-- | Database for (unsuccessfully) trying to expose a bug in the handling+-- of implied linking constraints. The question is whether an implied linking+-- constraint should only have the introducing package in its conflict set,+-- or also its link target.+--+-- It turns out that as long as the Single Instance Restriction is in place,+-- it does not matter, because there will aways be an option that is failing+-- due to the SIR, which contains the link target in its conflict set.+--+-- Even if the SIR is not in place, if there is a solution, one will always+-- be found, because without the SIR, linking is always optional, but never+-- necessary.+--+testIndepGoals5 :: String -> GoalOrder -> SolverTest+testIndepGoals5 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = independentGoals $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 [ExAny "C"]+      , Right $ exAv "C" 1 []+      , Right $ exAv "C" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "X"+      , P (Indep 0) "A"+      , P (Indep 0) "B"+      , P (Indep 0) "C"+      , P (Indep 1) "Y"+      , P (Indep 1) "A"+      , P (Indep 1) "B"+      , P (Indep 1) "C"+      ]++-- | A simplified version of 'testIndepGoals5'.+testIndepGoals6 :: String -> GoalOrder -> SolverTest+testIndepGoals6 name fixGoalOrder =+    case fixGoalOrder of+      FixedGoalOrder   -> goalOrder goals test+      DefaultGoalOrder -> test+  where+    test :: SolverTest+    test = independentGoals $ mkTest db name ["X", "Y"] $+           solverSuccess+           [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]++    db :: ExampleDb+    db = [+        Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]+      , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2]+      , Right $ exAv "A" 1 []+      , Right $ exAv "A" 2 [ExAny "B"]+      , Right $ exAv "B" 1 []+      , Right $ exAv "B" 2 []+      ]++    goals :: [ExampleVar]+    goals = [+        P (Indep 0) "X"+      , P (Indep 0) "A"+      , P (Indep 0) "B"+      , P (Indep 1) "Y"+      , P (Indep 1) "A"+      , P (Indep 1) "B"+      ]++dbExts1 :: ExampleDb+dbExts1 = [+    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]+  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]+  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]+  ]++dbLangs1 :: ExampleDb+dbLangs1 = [+    Right $ exAv "A" 1 [ExLang Haskell2010]+  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]+  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]+  ]++-- | cabal must set enable-exe to false in order to avoid the unavailable+-- dependency. Flags are true by default. The flag choice causes "pkg" to+-- depend on "false-dep".+testBuildable :: String -> ExampleDependency -> TestTree+testBuildable testName unavailableDep =+    runTest $+    mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected+  where+    expected = solverSuccess [("false-dep", 1), ("pkg", 1)]+    db = [+        Right $ exAv "pkg" 1 [exFlagged "enable-exe"+                                 [ExAny "true-dep"]+                                 [ExAny "false-dep"]]+         `withExe`+            ExExe "exe" [ unavailableDep+                        , ExFlagged "enable-exe" (Buildable []) NotBuildable ]+      , Right $ exAv "true-dep" 1 []+      , Right $ exAv "false-dep" 1 []+      ]++-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages+-- "flag1-false" and "flag2-true".+dbBuildable1 :: ExampleDb+dbBuildable1 = [+    Right $ exAv "pkg" 1+        [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]+        , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]+     `withExes`+        [ ExExe "exe1"+            [ ExAny "unknown"+            , ExFlagged "flag1" (Buildable []) NotBuildable+            , ExFlagged "flag2" (Buildable []) NotBuildable]+        , ExExe "exe2"+            [ ExAny "unknown"+            , ExFlagged "flag1"+                  (Buildable [])+                  (Buildable [ExFlagged "flag2" NotBuildable (Buildable [])])]+         ]+  , Right $ exAv "flag1-true" 1 []+  , Right $ exAv "flag1-false" 1 []+  , Right $ exAv "flag2-true" 1 []+  , Right $ exAv "flag2-false" 1 []+  ]++-- | cabal must pick B-2 to avoid the unknown dependency.+dbBuildable2 :: ExampleDb+dbBuildable2 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "unknown"]+  , Right $ exAv "B" 2 []+     `withExe`+        ExExe "exe"+        [ ExAny "unknown"+        , ExFlagged "disable-exe" NotBuildable (Buildable [])+        ]+  , Right $ exAv "B" 3 [ExAny "unknown"]+  ]++-- | Package databases for testing @pkg-config@ dependencies.+dbPC1 :: ExampleDb+dbPC1 = [+    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]+  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]+  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  ]++{-------------------------------------------------------------------------------+  Simple databases for the illustrations for the backjumping blog post+-------------------------------------------------------------------------------}++-- | Motivate conflict sets+dbBJ1a :: ExampleDb+dbBJ1a = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2]+  , Right $ exAv "B" 1 []+  ]++-- | Show that we can skip some decisions+dbBJ1b :: ExampleDb+dbBJ1b = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Motivate why both A and B need to be in the conflict set+dbBJ1c :: ExampleDb+dbBJ1c = [+    Right $ exAv "A" 1 [ExFix "B" 1]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 []+  ]++-- | Motivate the need for accumulating conflict sets while we walk the tree+dbBJ2 :: ExampleDb+dbBJ2 = [+    Right $ exAv "A"  1 [ExFix "B" 1]+  , Right $ exAv "A"  2 [ExFix "B" 2]+  , Right $ exAv "B"  1 [ExFix "C" 1]+  , Right $ exAv "B"  2 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | Motivate the need for `QGoalReason`+dbBJ3 :: ExampleDb+dbBJ3 = [+    Right $ exAv "A"  1 [ExAny "Ba"]+  , Right $ exAv "A"  2 [ExAny "Bb"]+  , Right $ exAv "Ba" 1 [ExFix "C" 1]+  , Right $ exAv "Bb" 1 [ExFix "C" 2]+  , Right $ exAv "C"  1 []+  ]++-- | `QGOalReason` not unique+dbBJ4 :: ExampleDb+dbBJ4 = [+    Right $ exAv "A" 1 [ExAny "B", ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++-- | Flags are represented somewhat strangely in the tree+--+-- This example probably won't be in the blog post itself but as a separate+-- bug report (#3409)+dbBJ5 :: ExampleDb+dbBJ5 = [+    Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]]+  , Right $ exAv "B" 1 [ExFix "D" 1]+  , Right $ exAv "C" 1 [ExFix "D" 2]+  , Right $ exAv "D" 1 []+  ]++-- | Conflict sets for cycles+dbBJ6 :: ExampleDb+dbBJ6 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 []+  , Right $ exAv "B" 2 [ExAny "C"]+  , Right $ exAv "C" 1 [ExAny "A"]+  ]++-- | Conflicts not unique+dbBJ7 :: ExampleDb+dbBJ7 = [+    Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1]+  , Right $ exAv "B" 1 [ExFix "C" 1]+  , Right $ exAv "C" 1 []+  , Right $ exAv "C" 2 []+  ]++-- | Conflict sets for SIR (C shared subgoal of independent goals A, B)+dbBJ8 :: ExampleDb+dbBJ8 = [+    Right $ exAv "A" 1 [ExAny "C"]+  , Right $ exAv "B" 1 [ExAny "C"]+  , Right $ exAv "C" 1 []+  ]++{-------------------------------------------------------------------------------+  Databases for build-tools+-------------------------------------------------------------------------------}+dbBuildTools1 :: ExampleDb+dbBuildTools1 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "A" 1 [ExBuildToolAny "alex"]+  ]++-- Test that build-tools on a random thing doesn't matter (only+-- the ones we recognize need to be in db)+dbBuildTools2 :: ExampleDb+dbBuildTools2 = [+    Right $ exAv "A" 1 [ExBuildToolAny "otherdude"]+  ]++-- Test that we can solve for different versions of executables+dbBuildTools3 :: ExampleDb+dbBuildTools3 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "alex" 2 [],+    Right $ exAv "A" 1 [ExBuildToolFix "alex" 1],+    Right $ exAv "B" 1 [ExBuildToolFix "alex" 2],+    Right $ exAv "C" 1 [ExAny "A", ExAny "B"]+  ]++-- Test that exe is not related to library choices+dbBuildTools4 :: ExampleDb+dbBuildTools4 = [+    Right $ exAv "alex" 1 [ExFix "A" 1],+    Right $ exAv "A" 1 [],+    Right $ exAv "A" 2 [],+    Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2]+  ]++-- Test that build-tools on build-tools works+dbBuildTools5 :: ExampleDb+dbBuildTools5 = [+    Right $ exAv "alex" 1 [],+    Right $ exAv "happy" 1 [ExBuildToolAny "alex"],+    Right $ exAv "A" 1 [ExBuildToolAny "happy"]+  ]++-- Test that build-depends on library/executable package works.+-- Extracted from https://github.com/haskell/cabal/issues/3775+dbBuildTools6 :: ExampleDb+dbBuildTools6 = [+    Right $ exAv "warp" 1 [],+    -- NB: the warp build-depends refers to the package, not the internal+    -- executable!+    Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` ExExe "warp" [ExAny "A"],+    Right $ exAv "B" 2 [ExAny "A", ExAny "warp"]+  ]
+ tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ParallelListComp #-}+module UnitTests.Distribution.Solver.Modular.WeightedPSQ (+  tests+  ) where++import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Data.List (sort)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (Blind(..), testProperty)++tests :: [TestTree]+tests = [+    testProperty "'toList . fromList' preserves elements" $ \xs ->+        sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs))++  , testProperty "'toList . fromList' sorts stably" $ \xs ->+        let indexAsValue :: [(Int, (), Int)]+            indexAsValue = [(x, (), i) | x <- xs | i <- [0..]]+        in isSorted $ W.toList $ W.fromList indexAsValue++  , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) ->+        isSorted $ W.weights $+        W.mapWeightsWithKey (f :: Int -> Int -> Int) $+        W.fromList (xs :: [(Int, Int, Int)])++  , testCase "applying 'mapWeightsWithKey' twice sorts twice" $+        let indexAsKey :: [((), Int, ())]+            indexAsKey = [((), i, ()) | i <- [0..10]]+            actual = W.toList $+                     W.mapWeightsWithKey (\_ _ -> ()) $+                     W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored+                     W.fromList indexAsKey+        in reverse indexAsKey @?= actual++  , testProperty "'union' sorts by weight" $ \xs ys ->+        isSorted $ W.weights $+        W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)]))++  , testProperty "'union' preserves elements" $ \xs ys ->+        let union = W.union (W.fromList xs)+                            (W.fromList (ys :: [(Int, Int, Int)]))+        in sort (xs ++ ys) == sort (W.toList union)++  , testCase "'lookup' returns first occurrence" $+        let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')]+        in Just 'C' @?= W.lookup True xs+  ]++isSorted :: Ord a => [a] -> Bool+isSorted (x1 : xs@(x2 : _)) = x1 <= x2 && isSorted xs+isSorted _ = True