packages feed

cabal-install 1.22.9.0 → 1.24.0.0

raw patch · 204 files changed

+25233/−5774 lines, 204 filesdep +asyncdep +base16-bytestringdep +binarydep −HUnitdep −extensible-exceptionsdep −test-frameworkdep ~Cabaldep ~HTTPdep ~QuickCheckbuild-type:Customsetup-changed

Dependencies added: async, base16-bytestring, binary, bytestring-builder, cryptohash-sha256, ghc-prim, hackage-security, hashable, tagged, tar, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: HUnit, extensible-exceptions, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: Cabal, HTTP, QuickCheck, array, base, bytestring, containers, directory, filepath, network, network-uri, pretty, process, random, time, unix

Files

Distribution/Client/BuildReports/Anonymous.hs view
@@ -191,7 +191,6 @@   ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror   ParseOk   _ report -> Right report ---FIXME: this does not allow for optional or repeated fields parseFields :: String -> ParseResult BuildReport parseFields input = do   fields <- mapM extractField =<< readFields input
Distribution/Client/BuildReports/Storage.hs view
@@ -28,6 +28,7 @@  import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.ComponentDeps as CD import Distribution.Client.InstallPlan          ( InstallPlan ) @@ -74,10 +75,13 @@              . onlyRemote     repoName (_,_,rrepo) = remoteRepoName rrepo -    onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote :: [(BuildReport, Maybe Repo)]+               -> [(BuildReport, Repo, RemoteRepo)]     onlyRemote rs =       [ (report, repo, remoteRepo)-      | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]+      | (report, Just repo) <- rs+      , Just remoteRepo     <- [maybeRepoRemote repo]+      ]  storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]            -> Platform -> IO ()@@ -115,34 +119,39 @@ -- * InstallPlan support -- ------------------------------------------------------------ -fromInstallPlan :: InstallPlan -> [(BuildReport, Maybe Repo)]-fromInstallPlan plan = catMaybes-                     . map (fromPlanPackage platform comp)-                     . InstallPlan.toList-                     $ plan-  where platform = InstallPlan.planPlatform plan-        comp     = compilerInfoId (InstallPlan.planCompiler plan)+fromInstallPlan :: Platform -> CompilerId+                -> InstallPlan+                -> [(BuildReport, Maybe Repo)]+fromInstallPlan platform comp plan =+     catMaybes+   . map (fromPlanPackage platform comp)+   . InstallPlan.toList+   $ plan  fromPlanPackage :: Platform -> CompilerId                 -> InstallPlan.PlanPackage                 -> Maybe (BuildReport, Maybe Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of-  InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result+  InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ _) deps)+                         _ result     -> Just $ ( BuildReport.new os arch comp-                                (packageId srcPkg) flags (map packageId deps)+                                (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 deps+                                (packageId srcPkg) flags+                                (map confSrcId (CD.nonSetupDeps deps))                                 (Left result)               , extractRepo srcPkg )    _ -> Nothing    where-    extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo+    extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })+                  = Just repo     extractRepo _ = Nothing  fromPlanningFailure :: Platform -> CompilerId
Distribution/Client/BuildReports/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.BuildReports.Types@@ -24,9 +25,14 @@  import Data.Char as Char          ( isAlpha, toLower )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary) + data ReportLevel = NoReports | AnonymousReports | DetailedReports-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Enum, Show, Generic)++instance Binary ReportLevel  instance Text.Text ReportLevel where   disp NoReports        = Disp.text "none"
Distribution/Client/BuildReports/Upload.hs view
@@ -5,17 +5,17 @@     ( BuildLog     , BuildReportId     , uploadReports-    , postBuildReport-    , putBuildLog     ) where +{- import Network.Browser          ( BrowserAction, request, setAllowRedirects ) import Network.HTTP          ( Header(..), HeaderName(..)          , Request(..), RequestMethod(..), Response(..) ) import Network.TCP (HandleStream)-import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)+-}+import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)  import Control.Monad          ( forM_ )@@ -24,22 +24,33 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die)+import Distribution.Client.HttpUtils+import Distribution.Client.Setup+         ( RepoContext(..) )  type BuildReportId = URI type BuildLog = String -uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]-              ->  BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports = do+uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()+uploadReports verbosity repoCtxt auth uri reports = do   forM_ reports $ \(report, mbBuildLog) -> do-     buildId <- postBuildReport uri report+     buildId <- postBuildReport verbosity repoCtxt auth uri report      case mbBuildLog of-       Just buildLog -> putBuildLog buildId buildLog+       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog        Nothing       -> return () -postBuildReport :: URI -> BuildReport-                -> BrowserAction (HandleStream BuildLog) BuildReportId-postBuildReport uri buildReport = do+postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId+postBuildReport verbosity repoCtxt auth uri buildReport = do+  let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }+  transport <- repoContextGetTransport repoCtxt+  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++{-   setAllowRedirects False   (_, response) <- request Request {     rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },@@ -64,17 +75,18 @@               -> return $ buildId     _         -> error "Unrecognised response from server."   where body  = BuildReport.show buildReport+-} -putBuildLog :: BuildReportId -> BuildLog-            -> BrowserAction (HandleStream BuildLog) ()-putBuildLog reportId buildLog = do-  --FIXME: do something if the request fails-  (_, _response) <- request Request {-      rqURI     = reportId{uriPath = uriPath reportId </> "log"},-      rqMethod  = PUT,-      rqHeaders = [Header HdrContentType   ("text/plain"),-                   Header HdrContentLength (show (length buildLog)),-                   Header HdrAccept        ("text/plain")],-      rqBody    = buildLog-    }-  return ()++-- TODO force this to be a PUT?++putBuildLog :: Verbosity -> RepoContext -> (String, String)+            -> BuildReportId -> BuildLog+            -> IO ()+putBuildLog verbosity repoCtxt auth reportId buildLog = do+  let fullURI = reportId {uriPath = uriPath reportId </> "log"}+  transport <- repoContextGetTransport repoCtxt+  res <- postHttp transport verbosity fullURI buildLog (Just auth)+  case res of+    (200, _) -> return ()+    _ -> die "unrecognized response" -- give response
+ Distribution/Client/BuildTarget.hs view
@@ -0,0 +1,1623 @@+{-# 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
@@ -50,6 +50,7 @@         buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]         buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]         distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+                          ++ [ x | x@PackageDistSuspiciousWarn {}  <- packageChecks ]         distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]      unless (null buildImpossible) $ do@@ -68,8 +69,11 @@         putStrLn "The following errors will cause portability problems on other environments:"         printCheckMessages distInexusable -    let isDistError (PackageDistSuspicious {}) = False-        isDistError _                          = True+    let isDistError (PackageDistSuspicious     {}) = False+        isDistError (PackageDistSuspiciousWarn {}) = False+        isDistError _                              = True+        isCheckError (PackageDistSuspiciousWarn {}) = False+        isCheckError _                              = True         errors = filter isDistError packageChecks      unless (null errors) $@@ -78,7 +82,7 @@     when (null packageChecks) $         putStrLn "No errors or warnings could be found in the package." -    return (null packageChecks)+    return (null . filter isCheckError $ packageChecks)    where     printCheckMessages = mapM_ (putStrLn . format . explanation)
+ Distribution/Client/CmdBuild.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | cabal-install CLI command: build+--+module Distribution.Client.CmdBuild (+    buildAction,+  ) where++import Distribution.Client.ProjectOrchestration+         ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets+         , ProjectBuildContext(..), runProjectBuildPhase,  printPlan )+import Distribution.Client.ProjectConfig+         ( BuildTimeSettings(..) )+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )+import Distribution.Client.BuildTarget+         ( readUserBuildTargets )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Control.Monad (unless)+++-- | The @build@ command does a lot. It brings the install plan up to date,+-- selects that part of the plan needed by the given or implicit targets and+-- then executes the plan.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+            -> [String] -> GlobalFlags -> IO ()+buildAction (configFlags, configExFlags, installFlags, haddockFlags)+            targetStrings globalFlags = do++    userTargets <- readUserBuildTargets targetStrings++    buildCtx@ProjectBuildContext{buildSettings} <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning      = \_ _ _ -> return (),+          hookSelectPlanSubset = selectBuildTargets userTargets+        }++    printPlan verbosity buildCtx++    unless (buildSettingDryRun buildSettings) $+      runProjectBuildPhase+        verbosity+        buildCtx+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)++    -- 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+
+ Distribution/Client/CmdConfigure.hs view
@@ -0,0 +1,60 @@+-- | cabal-install CLI command: configure+--+module Distribution.Client.CmdConfigure (+    configureAction,+  ) where++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )+++-- | To a first approximation, the @configure@ just runs the first phase of+-- the @build@ command where we bring the install plan up to date (thus+-- checking that it's possible).+--+-- The only difference is that @configure@ also allows the user to specify+-- some extra config flags which we save in the file @cabal.project.local@.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+                -> [String] -> GlobalFlags -> IO ()+configureAction (configFlags, configExFlags, installFlags, haddockFlags)+                _extraArgs globalFlags = do+    --TODO: deal with _extraArgs, since flags with wrong syntax end up there++    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,++          hookSelectPlanSubset = return+        }++    --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+        }+      }+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+
+ Distribution/Client/CmdRepl.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | cabal-install CLI command: repl+--+module Distribution.Client.CmdRepl (+    replAction,+  ) where++import Distribution.Client.ProjectOrchestration+         ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets+         , ProjectBuildContext(..), runProjectBuildPhase,  printPlan )+import Distribution.Client.ProjectConfig+         ( BuildTimeSettings(..) )+import Distribution.Client.ProjectPlanning+         ( PackageTarget(..) )+import Distribution.Client.BuildTarget+         ( readUserBuildTargets )++import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )+import Distribution.Simple.Setup+         ( HaddockFlags, fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Control.Monad (unless)+++-- | The @repl@ command is very much like @build@. It brings the install plan+-- up to date, selects that part of the plan needed by the given or implicit+-- repl target and then executes the plan.+--+-- Compared to @build@ the difference is that only one target is allowed+-- (given or implicit) and the target type is repl rather than build. The+-- general plan execution infrastructure handles both build and repl targets.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)+              -> [String] -> GlobalFlags -> IO ()+replAction (configFlags, configExFlags, installFlags, haddockFlags)+           targetStrings globalFlags = do++    userTargets <- readUserBuildTargets targetStrings++    buildCtx@ProjectBuildContext{buildSettings} <-+      runProjectPreBuildPhase+        verbosity+        ( globalFlags, configFlags, configExFlags+        , installFlags, haddockFlags )+        PreBuildHooks {+          hookPrePlanning      = \_ _ _ -> return (),+          hookSelectPlanSubset = selectReplTargets userTargets+        }++    printPlan verbosity buildCtx++    unless (buildSettingDryRun buildSettings) $+      runProjectBuildPhase+        verbosity+        buildCtx+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)++    -- 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+
− Distribution/Client/Compat/Environment.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Compat.Environment--- Copyright   :  (c) Simon Hengel 2012--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ A cross-platform library for setting environment variables.-----------------------------------------------------------------------------------module Distribution.Client.Compat.Environment (-  lookupEnv, setEnv-) where--#ifdef mingw32_HOST_OS-import GHC.Windows-import Foreign.C-import Control.Monad-#else-import Foreign.C.Types-import Foreign.C.String-import Foreign.C.Error (throwErrnoIfMinus1_)-import System.Posix.Internals ( withFilePath )-#endif /* mingw32_HOST_OS */--#if MIN_VERSION_base(4,6,0)-import System.Environment (lookupEnv)-#else-import System.Environment (getEnv)-import Distribution.Compat.Exception (catchIO)-#endif--#if !MIN_VERSION_base(4,6,0)--- | @lookupEnv var@ returns the value of the environment variable @var@, or--- @Nothing@ if there is no such value.-lookupEnv :: String -> IO (Maybe String)-lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)-#endif /* !MIN_VERSION_base(4,6,0) */---- | @setEnv name value@ sets the specified environment variable to @value@.------ Throws `Control.Exception.IOException` if either @name@ or @value@ is the--- empty string or contains an equals sign.-setEnv :: String -> String -> IO ()-setEnv key value_-  | null value = error "Distribuiton.Compat.setEnv: empty string"-  | otherwise  = setEnv_ key value-  where-    -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We-    -- still strip it manually so that the null check above succeeds if a value-    -- starts with NUL.-    value = takeWhile (/= '\NUL') value_--setEnv_ :: String -> String -> IO ()--#ifdef mingw32_HOST_OS--setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do-  success <- c_SetEnvironmentVariable k v-  unless success (throwGetLastError "setEnv")--# 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 /* i386_HOST_ARCH */--foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"-  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool-#else-setEnv_ key value = do-  withFilePath key $ \ keyP ->-    withFilePath value $ \ valueP ->-      throwErrnoIfMinus1_ "setenv" $-        c_setenv keyP valueP (fromIntegral (fromEnum True))--foreign import ccall unsafe "setenv"-   c_setenv :: CString -> CString -> CInt -> IO CInt-#endif /* mingw32_HOST_OS */
Distribution/Client/Compat/Time.hs view
@@ -1,74 +1,69 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} module Distribution.Client.Compat.Time-       (EpochTime, getModTime, getFileAge, getCurTime)+       ( ModTime(..) -- Needed for testing+       , getModTime, getFileAge, getCurTime+       , posixSecondsToModTime )        where -import Data.Int (Int64)-import System.Directory (getModificationTime)+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 (utcTimeToPOSIXSeconds, posixDayLength)-import Data.Time (getCurrentTime, diffUTCTime)+import Data.Time.Clock.POSIX ( posixDayLength )+import Data.Time             ( diffUTCTime, getCurrentTime ) #else-import System.Time (ClockTime(..), getClockTime-                   ,diffClockTimes, normalizeTimeDiff, tdDay, tdHour)+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, unsafeShiftL)-#else-import Data.Bits          ((.|.), bitSize, unsafeShiftL)-#endif-import Data.Int           (Int32)-import Data.Word          (Word64)-import Foreign            (allocaBytes, peekByteOff)-import System.IO.Error    (mkIOError, doesNotExistErrorType)-import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString)--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall+import Data.Bits          (finiteBitSize) #else-#define CALLCONV stdcall+import Data.Bits          (bitSize) #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+import Data.Int           ( Int32 )+import Foreign            ( allocaBytes, peekByteOff )+import System.IO.Error    ( mkIOError, doesNotExistErrorType )+import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20+#else -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24+import System.Posix.Files ( FileStatus, getFileStatus ) +#if MIN_VERSION_unix(2,6,0)+import System.Posix.Files ( modificationTimeHiRes ) #else--import Foreign.C.Types    (CTime(..))-import System.Posix.Files (getFileStatus, modificationTime)+import System.Posix.Files ( modificationTime )+#endif  #endif --- | The number of seconds since the UNIX epoch.-type EpochTime = Int64+-- | 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) --- | Return modification time of given file. Works around the low clock+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 OpenShake by--- Neil Mitchell. See module Development.Shake.FileTime.-getModTime :: FilePath -> IO EpochTime+-- 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 @@ -86,39 +81,74 @@                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime       dwHigh <- peekByteOff info                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-      return $! windowsTimeToPOSIXSeconds dwLow dwHigh-        where-          windowsTimeToPOSIXSeconds :: DWORD -> DWORD -> EpochTime-          windowsTimeToPOSIXSeconds dwLow dwHigh =-            let wINDOWS_TICK      = 10000000-                sEC_TO_UNIX_EPOCH = 11644473600 #if MIN_VERSION_base(4,7,0)-                qwTime = (fromIntegral dwHigh `unsafeShiftL` finiteBitSize dwHigh)-                         .|. (fromIntegral dwLow)+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD)) #else-                qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)-                         .|. (fromIntegral dwLow)+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD)) #endif-                res    = ((qwTime :: Word64) `div` wINDOWS_TICK)-                         - sEC_TO_UNIX_EPOCH-            -- TODO: What if the result is not representable as POSIX seconds?-            -- Probably fine to return garbage.-            in fromIntegral res+      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-    -- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in-    -- base < 4.5.-    t <- fmap modificationTime $ getFileStatus path-#if MIN_VERSION_base(4,5,0)-    let CTime i = t-    return (fromIntegral i)+    st <- getFileStatus path+    return $! (extractFileTime st)++extractFileTime :: FileStatus -> ModTime+#if MIN_VERSION_unix(2,6,0)+extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) #else-    return (read . show $ t)+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@@ -132,11 +162,6 @@   return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0 #endif -getCurTime :: IO EpochTime-getCurTime =  do-#if MIN_VERSION_directory(1,2,0)-  (truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime-#else-  (TOD s _) <- getClockTime-  return $! fromIntegral s-#endif+-- | Return the current time as 'ModTime'.+getCurTime :: IO ModTime+getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
+ Distribution/Client/ComponentDeps.hs view
@@ -0,0 +1,161 @@+-- | 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
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Config@@ -15,6 +16,7 @@ module Distribution.Client.Config (     SavedConfig(..),     loadConfig,+    getConfigFilePath,      showConfig,     showConfigWithComments,@@ -36,20 +38,25 @@     withProgramsFields,     withProgramOptionsFields,     userConfigDiff,-    userConfigUpdate+    userConfigUpdate,+    createDefaultConfigFile,++    remoteRepoFields   ) where  import Distribution.Client.Types-         ( RemoteRepo(..), Username(..), Password(..) )+         ( 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          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand-         , showRepo, parseRepo )+         , showRepo, parseRepo, readRepo ) import Distribution.Utils.NubList          ( NubList, fromNubList, toNubList) @@ -57,8 +64,9 @@          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , AllowNewer(..)          , HaddockFlags(..), haddockOptions, defaultHaddockFlags-         , installDirsOptions+         , installDirsOptions, optionDistPref          , programConfigurationPaths', programConfigurationOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs@@ -69,9 +77,12 @@          , ParseResult(..), PError(..), PWarning(..)          , locatedErrorMsg, showPWarning          , readFields, warning, lineNo-         , simpleField, listField, parseFilePathQ, parseTokenQ )+         , simpleField, listField, spaceListField+         , parseFilePathQ, parseOptCommaList, parseTokenQ ) import Distribution.Client.ParseUtils          ( parseFields, ppFields, ppSection )+import Distribution.Client.HttpUtils+         ( isOldHackageURI ) import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) ) import qualified Distribution.Text as Text@@ -92,22 +103,21 @@          ( partition, find, foldl' ) import Data.Maybe          ( fromMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif import Control.Monad-         ( unless, foldM, liftM, liftM2 )+         ( when, unless, foldM, liftM, liftM2 ) import qualified Distribution.Compat.ReadP as Parse-         ( option )+         ( (<++), option )+import Distribution.Compat.Semigroup import qualified Text.PrettyPrint as Disp          ( render, text, empty ) import Text.PrettyPrint          ( ($+$) )+import Text.PrettyPrint.HughesPJ+         ( text, Doc ) import System.Directory          ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI-         ( URI(..), URIAuth(..) )+         ( URI(..), URIAuth(..), parseURI ) import System.FilePath          ( (<.>), (</>), takeDirectory ) import System.IO.Error@@ -123,6 +133,11 @@ import Data.Char          ( isSpace ) import qualified Data.Map as M+import Data.Function+         ( on )+import Data.List+         ( nubBy )+import GHC.Generics ( Generic )  -- -- * Configuration saved in the config file@@ -138,21 +153,14 @@     savedUploadFlags       :: UploadFlags,     savedReportFlags       :: ReportFlags,     savedHaddockFlags      :: HaddockFlags-  }+  } deriving Generic  instance Monoid SavedConfig where-  mempty = SavedConfig {-    savedGlobalFlags       = mempty,-    savedInstallFlags      = mempty,-    savedConfigureFlags    = mempty,-    savedConfigureExFlags  = mempty,-    savedUserInstallDirs   = mempty,-    savedGlobalInstallDirs = mempty,-    savedUploadFlags       = mempty,-    savedReportFlags       = mempty,-    savedHaddockFlags      = mempty-  }-  mappend a b = SavedConfig {+  mempty = gmempty+  mappend = (<>)++instance Semigroup SavedConfig where+  a <> b = SavedConfig {     savedGlobalFlags       = combinedSavedGlobalFlags,     savedInstallFlags      = combinedSavedInstallFlags,     savedConfigureFlags    = combinedSavedConfigureFlags,@@ -185,6 +193,11 @@       combine'        field subfield =         (subfield . field $ a) `mappend` (subfield . field $ b) +      combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)+                    -> mon+      combineMonoid field subfield =+        (subfield . field $ a) `mappend` (subfield . field $ b)+       lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]       lastNonEmpty'   field subfield =         let a' = subfield . field $ a@@ -205,13 +218,16 @@         globalNumericVersion    = combine globalNumericVersion,         globalConfigFile        = combine globalConfigFile,         globalSandboxConfigFile = combine globalSandboxConfigFile,+        globalConstraintsFile   = combine globalConstraintsFile,         globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,         globalCacheDir          = combine globalCacheDir,         globalLocalRepos        = lastNonEmptyNL globalLocalRepos,         globalLogsDir           = combine globalLogsDir,         globalWorldFile         = combine globalWorldFile,         globalRequireSandbox    = combine globalRequireSandbox,-        globalIgnoreSandbox     = combine globalIgnoreSandbox+        globalIgnoreSandbox     = combine globalIgnoreSandbox,+        globalIgnoreExpiry      = combine globalIgnoreExpiry,+        globalHttpTransport     = combine globalHttpTransport         }         where           combine        = combine'        savedGlobalFlags@@ -240,14 +256,15 @@         installSymlinkBinDir         = combine installSymlinkBinDir,         installOneShot               = combine installOneShot,         installNumJobs               = combine installNumJobs,-        installRunTests              = combine installRunTests+        installRunTests              = combine installRunTests,+        installOfflineMode           = combine installOfflineMode         }         where           combine        = combine'        savedInstallFlags           lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags        combinedSavedConfigureFlags = ConfigFlags {-        configPrograms            = configPrograms . savedConfigureFlags $ b,+        configPrograms_           = configPrograms_ . savedConfigureFlags $ b,         -- TODO: NubListify         configProgramPaths        = lastNonEmpty configProgramPaths,         -- TODO: NubListify@@ -258,9 +275,12 @@         configHcPkg               = combine configHcPkg,         configVanillaLib          = combine configVanillaLib,         configProfLib             = combine configProfLib,+        configProf                = combine configProf,         configSharedLib           = combine configSharedLib,         configDynExe              = combine configDynExe,         configProfExe             = combine configProfExe,+        configProfDetail          = combine configProfDetail,+        configProfLibDetail       = combine configProfLibDetail,         -- TODO: NubListify         configConfigureArgs       = lastNonEmpty configConfigureArgs,         configOptimization        = combine configOptimization,@@ -275,7 +295,10 @@         -- TODO: NubListify         configExtraLibDirs        = lastNonEmpty configExtraLibDirs,         -- TODO: NubListify+        configExtraFrameworkDirs  = lastNonEmpty configExtraFrameworkDirs,+        -- TODO: NubListify         configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,+        configIPID                = combine configIPID,         configDistPref            = combine configDistPref,         configVerbosity           = combine configVerbosity,         configUserInstall         = combine configUserInstall,@@ -289,7 +312,6 @@         configConstraints         = lastNonEmpty configConstraints,         -- TODO: NubListify         configDependencies        = lastNonEmpty configDependencies,-        configInstantiateWith     = lastNonEmpty configInstantiateWith,         -- TODO: NubListify         configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,         configTests               = combine configTests,@@ -298,7 +320,9 @@         configLibCoverage         = combine configLibCoverage,         configExactConfiguration  = combine configExactConfiguration,         configFlagError           = combine configFlagError,-        configRelocatable         = combine configRelocatable+        configRelocatable         = combine configRelocatable,+        configAllowNewer          = combineMonoid savedConfigureFlags+                                    configAllowNewer         }         where           combine        = combine'        savedConfigureFlags@@ -311,8 +335,7 @@         configExConstraints = lastNonEmpty configExConstraints,         -- TODO: NubListify         configPreferences   = lastNonEmpty configPreferences,-        configSolver        = combine configSolver,-        configAllowNewer    = combine configAllowNewer+        configSolver        = combine configSolver         }         where           combine      = combine' savedConfigureExFlags@@ -327,10 +350,12 @@                                        `mappend` savedGlobalInstallDirs b        combinedSavedUploadFlags = UploadFlags {-        uploadCheck     = combine uploadCheck,-        uploadUsername  = combine uploadUsername,-        uploadPassword  = combine uploadPassword,-        uploadVerbosity = combine uploadVerbosity+        uploadCheck       = combine uploadCheck,+        uploadDoc         = combine uploadDoc,+        uploadUsername    = combine uploadUsername,+        uploadPassword    = combine uploadPassword,+        uploadPasswordCmd = combine uploadPasswordCmd,+        uploadVerbosity   = combine uploadVerbosity         }         where           combine = combine' savedUploadFlags@@ -351,6 +376,7 @@         haddockHoogle        = combine haddockHoogle,         haddockHtml          = combine haddockHtml,         haddockHtmlLocation  = combine haddockHtmlLocation,+        haddockForHackage    = combine haddockForHackage,         haddockExecutables   = combine haddockExecutables,         haddockTestSuites    = combine haddockTestSuites,         haddockBenchmarks    = combine haddockBenchmarks,@@ -368,24 +394,6 @@           lastNonEmpty = lastNonEmpty'   savedHaddockFlags  -updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig-updateInstallDirs userInstallFlag-  savedConfig@SavedConfig {-    savedConfigureFlags    = configureFlags,-    savedUserInstallDirs   = userInstallDirs,-    savedGlobalInstallDirs = globalInstallDirs-  } =-  savedConfig {-    savedConfigureFlags = configureFlags {-      configInstallDirs = installDirs-    }-  }-  where-    installDirs | userInstall = userInstallDirs-                | otherwise   = globalInstallDirs-    userInstall = fromFlagOrDefault defaultUserInstall $-                    configUserInstall configureFlags `mappend` userInstallFlag- -- -- * Default config --@@ -430,7 +438,7 @@   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = toNubList [defaultRemoteRepo],+      globalRemoteRepos  = toNubList [addInfoForKnownRepos defaultRemoteRepo],       globalWorldFile    = toFlag worldFile     },     savedConfigureFlags  = mempty {@@ -483,37 +491,47 @@ -- global installs on Windows but that no longer works on Windows Vista or 7.  defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri+defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False   where     name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""+    uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""+    -- Note that lots of old ~/.cabal/config files will have the old url+    -- http://hackage.haskell.org/packages/archive+    -- but new config files can use the new url (without the /packages/archive)+    -- and avoid having to do a http redirect +-- For the default repo we know extra information, fill this in. ----- * Config file reading+-- We need this because the 'defaultRemoteRepo' above is only used for the+-- first time when a config file is made. So for users with older config files+-- we might have only have older info. This lets us fill that in even for old+-- config files. ----loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig-loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do-  let sources = [-        ("commandline option",   return . flagToMaybe $ configFileFlag),-        ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),-        ("default config file",  Just `liftM` defaultConfigFile) ]+-- TODO: Once we migrate from opt-in to opt-out security for the central+-- Hackage repository, we should enable security and specify keys and threshold+-- for repositories that have their security setting as 'Nothing' (default).+addInfoForKnownRepos :: RemoteRepo -> RemoteRepo+addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } =+      tryHttps+    $ if isOldHackageURI (remoteRepoURI repo) then defaultRemoteRepo else repo+  where+    tryHttps r = r { remoteRepoShouldTryHttps = True }+addInfoForKnownRepos other = other -      getSource [] = error "no config file path candidate found."-      getSource ((msg,action): xs) =-                        action >>= maybe (getSource xs) (return . (,) msg)+--+-- * Config file reading+-- -  (source, configFile) <- getSource sources+loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig+loadConfig verbosity configFileFlag = addBaseConf $ do+  (source, configFile) <- getConfigFilePathAndSource configFileFlag   minp <- readConfigFile mempty configFile   case minp of     Nothing -> do-      notice verbosity $ "Config file path source is " ++ source ++ "."+      notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."       notice verbosity $ "Config file " ++ configFile ++ " not found."-      notice verbosity $ "Writing default configuration to " ++ configFile-      commentConf <- commentSavedConfig-      initialConf <- initialSavedConfig-      writeConfigFile configFile commentConf initialConf-      return initialConf+      createDefaultConfigFile verbosity configFile+      loadConfig verbosity configFileFlag     Just (ParseOk ws conf) -> do       unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)@@ -528,11 +546,38 @@     addBaseConf body = do       base  <- baseSavedConfig       extra <- body-      return (updateInstallDirs userInstallFlag (base `mappend` extra))+      return (base `mappend` extra) +    sourceMsg CommandlineOption =   "commandline option"+    sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"+    sourceMsg Default =             "default config file"++data ConfigFileSource = CommandlineOption+                      | EnvironmentVariable+                      | Default++-- | Returns the config file path, without checking that the file exists.+-- The order of precedence is: input flag, CABAL_CONFIG, default location.+getConfigFilePath :: Flag FilePath -> IO FilePath+getConfigFilePath = fmap snd . getConfigFilePathAndSource++getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)+getConfigFilePathAndSource configFileFlag =+    getSource sources+  where+    sources =+      [ (CommandlineOption,   return . flagToMaybe $ configFileFlag)+      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)+      , (Default,             Just `liftM` defaultConfigFile) ]++    getSource [] = error "no config file path candidate found."+    getSource ((source,action): xs) =+                      action >>= maybe (getSource xs) (return . (,) source)+ readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $-  fmap (Just . parseConfig initial) (readFile file)+  fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)+       (readFile file)    where     handleNotExists action = catchIO action $ \ioe ->@@ -540,6 +585,13 @@         then return Nothing         else ioError ioe +createDefaultConfigFile :: Verbosity -> FilePath -> IO ()+createDefaultConfigFile verbosity filePath = do+  commentConf <- commentSavedConfig+  initialConf <- initialSavedConfig+  notice verbosity $ "Writing default configuration to " ++ filePath+  writeConfigFile filePath commentConf initialConf+ writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do   let tmpFile = file <.> "tmp"@@ -576,7 +628,8 @@     savedInstallFlags      = defaultInstallFlags,     savedConfigureExFlags  = defaultConfigExFlags,     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {-      configUserInstall    = toFlag defaultUserInstall+      configUserInstall    = toFlag defaultUserInstall,+      configAllowNewer     = Just AllowNewerNone     },     savedUserInstallDirs   = fmap toFlag userInstallDirs,     savedGlobalInstallDirs = fmap toFlag globalInstallDirs,@@ -587,8 +640,8 @@  -- | All config file fields. ---configFieldDescriptions :: [FieldDescr SavedConfig]-configFieldDescriptions =+configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]+configFieldDescriptions src =       toSavedConfig liftGlobalFlag        (commandOptions (globalCommand []) ParseArgs)@@ -596,21 +649,34 @@    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "constraint", "dependency"]+       (["builddir", "constraint", "dependency", "ipid"]         ++ map fieldName installDirsFields) -        --FIXME: this is only here because viewAsFieldDescr gives us a parser+        -- This is only here because viewAsFieldDescr gives us a parser         -- that only recognises 'ghc' etc, the case-sensitive flag names, not         -- what the normal case-insensitive parser gives us.        [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+        simpleField "allow-newer"+        showAllowNewer parseAllowNewer+        configAllowNewer (\v flags -> flags { configAllowNewer = v })         -- TODO: The following is a temporary fix. The "optimization"         -- and "debug-info" fields are OptArg, and viewAsFieldDescr         -- fails on that. Instead of a hand-written hackaged parser         -- and printer, we should handle this case properly in the         -- library.-       ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $+       ,liftField configOptimization (\v flags ->+                                       flags { configOptimization = v }) $         let name = "optimization" in         FieldDescr name           (\f -> case f of@@ -630,7 +696,8 @@              where                lstr = lowercase str                caseWarning = PWarning $-                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")        ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $         let name = "debug-info" in         FieldDescr name@@ -653,11 +720,12 @@              where                lstr = lowercase str                caseWarning = PWarning $-                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")        ]    ++ toSavedConfig liftConfigExFlag-       (configureExOptions ParseArgs)+       (configureExOptions ParseArgs src)        [] []    ++ toSavedConfig liftInstallFlag@@ -666,7 +734,7 @@    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)-       ["verbose", "check"] []+       ["verbose", "check", "documentation"] []    ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)@@ -676,6 +744,20 @@        -- share the options or make then distinct. In any case        -- they should probably be per-server. +  ++ [ viewAsFieldDescr+       $ optionDistPref+       (configDistPref . savedConfigureFlags)+       (\distPref config ->+          config+          { savedConfigureFlags = (savedConfigureFlags config) {+               configDistPref = distPref }+          , savedHaddockFlags = (savedHaddockFlags config) {+               haddockDistPref = distPref }+          }+       )+       ParseArgs+     ]+   where     toSavedConfig lift options exclusions replacements =       [ lift (fromMaybe field replacement)@@ -709,6 +791,11 @@       (Disp.text . fromFlagOrDefault "" . fmap unPassword)       (optional (fmap Password parseTokenQ))       uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  , liftUploadFlag $+    spaceListField "hackage-password-command"+      Disp.text parseTokenQ+      (fromFlagOrDefault [] . uploadPasswordCmd)+                        (\d cfg -> cfg { uploadPasswordCmd = Flag d })   ]  ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields  ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields@@ -751,18 +838,31 @@ liftReportFlag = liftField   savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) -parseConfig :: SavedConfig -> String -> ParseResult SavedConfig-parseConfig initial = \str -> do+parseConfig :: ConstraintSource+            -> SavedConfig+            -> String+            -> ParseResult SavedConfig+parseConfig src initial = \str -> do   fields <- readFields str   let (knownSections, others) = partition isKnownSection fields   config <- parse others   let user0   = savedUserInstallDirs config       global0 = savedGlobalInstallDirs config-  (haddockFlags, user, global, paths, args) <-+  (remoteRepoSections0, haddockFlags, user, global, paths, args) <-     foldM parseSections-          (savedHaddockFlags config, user0, global0, [], [])+          ([], savedHaddockFlags config, user0, global0, [], [])           knownSections++  let remoteRepoSections =+          map addInfoForKnownRepos+        . reverse+        . nubBy ((==) `on` remoteRepoName)+        $ remoteRepoSections0+   return config {+    savedGlobalFlags       = (savedGlobalFlags config) {+       globalRemoteRepos   = toNubList remoteRepoSections+       },     savedConfigureFlags    = (savedConfigureFlags config) {        configProgramPaths  = paths,        configProgramArgs   = args@@ -773,43 +873,63 @@   }    where+    isKnownSection (ParseUtils.Section _ "repository" _ _)              = True+    isKnownSection (ParseUtils.F _ "remote-repo" _)                     = True     isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True     isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True     isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True     isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True     isKnownSection _                                                    = False -    parse = parseFields (configFieldDescriptions+    parse = parseFields (configFieldDescriptions src                       ++ deprecatedFieldDescriptions) initial -    parseSections accum@(h,u,g,p,a)+    parseSections (rs, h, u, g, p, a)+                 (ParseUtils.Section _ "repository" name fs) = do+      r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs+      when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $+        warning $ "'key-threshold' for repository " ++ show (remoteRepoName r')+               ++ " higher than number of keys"+      when (not (null (remoteRepoRootKeys r'))+            && remoteRepoSecure r' /= Just True) $+        warning $ "'root-keys' for repository " ++ show (remoteRepoName r')+               ++ " non-empty, but 'secure' not set to True."+      return (r':rs, h, u, g, p, a)++    parseSections (rs, h, u, g, p, a)+                 (ParseUtils.F lno "remote-repo" raw) = do+      let mr' = readRepo raw+      r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'+      return (r':rs, h, u, g, p, a)++    parseSections accum@(rs, h, u, g, p, a)                  (ParseUtils.Section _ "haddock" name fs)       | name == ""        = do h' <- parseFields haddockFlagsFields h fs-                               return (h', u, g, p, a)+                               return (rs, h', u, g, p, a)       | otherwise         = do           warning "The 'haddock' section should be unnamed"           return accum-    parseSections accum@(h,u,g,p,a)+    parseSections accum@(rs, h, u, g, p, a)                   (ParseUtils.Section _ "install-dirs" name fs)       | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (h, u', g, p, a)+                               return (rs, h, u', g, p, a)       | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (h, u, g', p, a)+                               return (rs, h, u, g', p, a)       | otherwise         = do           warning "The 'install-paths' section should be for 'user' or 'global'"           return accum       where name' = lowercase name-    parseSections accum@(h,u,g,p,a)+    parseSections accum@(rs, h, u, g, p, a)                  (ParseUtils.Section _ "program-locations" name fs)       | name == ""        = do p' <- parseFields withProgramsFields p fs-                               return (h, u, g, p', a)+                               return (rs, h, u, g, p', a)       | otherwise         = do           warning "The 'program-locations' section should be unnamed"           return accum-    parseSections accum@(h, u, g, p, a)+    parseSections accum@(rs, h, u, g, p, a)                   (ParseUtils.Section _ "program-default-options" name fs)       | name == ""        = do a' <- parseFields withProgramOptionsFields a fs-                               return (h, u, g, p, a')+                               return (rs, h, u, g, p, a')       | otherwise         = do           warning "The 'program-default-options' section should be unnamed"           return accum@@ -822,8 +942,14 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      ppFields configFieldDescriptions mcomment vals+      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos+           . savedGlobalFlags $ vals of+        [] -> Disp.text ""+        (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs   $+$ Disp.text ""+  $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))+               mcomment vals+  $+$ Disp.text ""   $+$ ppSection "haddock" "" haddockFlagsFields                 (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)   $+$ Disp.text ""@@ -846,10 +972,52 @@                (fmap (field . savedConfigureFlags) mcomment)                ((field . savedConfigureFlags) vals) +    -- skip fields based on field name.  currently only skips "remote-repo",+    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)+    skipSomeFields = filter ((/= "remote-repo") . fieldName)+ -- | Fields for the 'install-dirs' sections. installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions +ppRemoteRepoSection :: RemoteRepo -> Doc+ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals)+        remoteRepoFields def vals+  where+    def = Just (emptyRemoteRepo "ignored") { remoteRepoSecure = Just False }++remoteRepoFields :: [FieldDescr RemoteRepo]+remoteRepoFields =+    [ simpleField "url"+        (text . show)            (parseTokenQ >>= parseURI')+        remoteRepoURI            (\x repo -> repo { remoteRepoURI = x })+    , simpleField "secure"+        showSecure               (Just `fmap` Text.parse)+        remoteRepoSecure         (\x repo -> repo { remoteRepoSecure = x })+    , listField "root-keys"+        text                     parseTokenQ+        remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })+    , simpleField "key-threshold"+        showThreshold            Text.parse+        remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })+    ]+  where+    parseURI' uriString =+      case parseURI uriString of+        Nothing  -> fail $ "remote-repo: no parse on " ++ show uriString+        Just uri -> return uri++    showSecure  Nothing      = mempty       -- default 'secure' setting+    showSecure  (Just True)  = text "True"  -- user explicitly enabled it+    showSecure  (Just False) = text "False" -- user explicitly disabled it++    -- If the key-threshold is set to 0, we omit it as this is the default+    -- and it looks odd to have a value for key-threshold but not for 'secure'+    -- (note that an empty list of keys is already omitted by default, since+    -- that is what we do for all list fields)+    showThreshold 0 = mempty+    showThreshold t = text (show t)+ -- | Fields for the 'haddock' section. haddockFlagsFields :: [FieldDescr HaddockFlags] haddockFlagsFields = [ field@@ -877,7 +1045,7 @@ -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. userConfigDiff :: GlobalFlags -> IO [String] userConfigDiff globalFlags = do-  userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty+  userConfig <- loadConfig normal (globalConfigFile globalFlags)   testConfig <- liftM2 mappend baseSavedConfig initialSavedConfig   return $ reverse . foldl' createDiff [] . M.toList                 $ M.unionWith combine@@ -889,12 +1057,14 @@      combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)     combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)-    combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y+    combine x y = error $ "Can't happen : userConfigDiff "+                  ++ show x ++ " " ++ show y      createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]     createDiff acc (key, (Just a, Just b))         | a == b = acc-        | otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc+        | otherwise = ("+ " ++ key ++ ": " ++ b)+                      : ("- " ++ key ++ ": " ++ a) : acc     createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc     createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc     createDiff acc (_, (Nothing, Nothing)) = acc@@ -920,10 +1090,10 @@ -- | Update the user's ~/.cabal/config' keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> IO () userConfigUpdate verbosity globalFlags = do-  userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty+  userConfig <- loadConfig normal (globalConfigFile globalFlags)   newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig   commentConf <- commentSavedConfig-  cabalFile <- defaultConfigFile+  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags   let backup = cabalFile ++ ".backup"   notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."   renameFile cabalFile backup
Distribution/Client/Configure.hs view
@@ -13,34 +13,49 @@ ----------------------------------------------------------------------------- module Distribution.Client.Configure (     configure,+    configureSetupScript,     chooseCabalVersion,+    checkConfigExFlags   ) where  import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer)+import Distribution.Client.Dependency.Types+         ( ConstraintSource(..)+         , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) 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 )+         ( ConfigExFlags(..), configureCommand, filterConfigureFlags+         , RepoContext(..) ) import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets-         ( userToPackageConstraint )+         ( userToPackageConstraint, userConstraintPackageName )+import qualified Distribution.Client.ComponentDeps as CD+import Distribution.Package (PackageId)+import Distribution.Client.JobControl (Lock)  import Distribution.Simple.Compiler          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup-         ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)+         ( ConfigFlags(..), AllowNewer(..)+         , 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(..), packageName, Dependency(..), thisPackageVersion )+         ( Package(..), UnitId, packageName+         , Dependency(..), thisPackageVersion+         )+import qualified Distribution.PackageDescription as PkgDesc import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.PackageDescription.Configuration@@ -48,28 +63,33 @@ import Distribution.Version          ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, info, debug, die )+         ( warn, notice, debug, die )+import Distribution.Simple.Setup+         ( isAllowNewer ) 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)  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.-chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange-chooseCabalVersion configExFlags maybeVersion =+chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange+chooseCabalVersion configFlags maybeVersion =   maybe defaultVersionRange thisVersion maybeVersion   where     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed     -- for '--allow-newer' to work.-    allowNewer = fromFlagOrDefault False $-                 fmap isAllowNewer (configAllowNewer configExFlags)+    allowNewer = isAllowNewer+                 (fromMaybe AllowNewerNone $ configAllowNewer configFlags)      defaultVersionRange = if allowNewer                           then orLaterVersion (Version [1,19,2] [])@@ -78,7 +98,7 @@ -- | Configure the package found in the local directory configure :: Verbosity           -> PackageDBStack-          -> [Repo]+          -> RepoContext           -> Compiler           -> Platform           -> ProgramConfiguration@@ -86,66 +106,175 @@           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repos comp platform conf+configure verbosity packageDBs repoCtxt comp platform conf   configFlags configExFlags extraArgs = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-  sourcePkgDb       <- getSourcePackages    verbosity repos+  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+  pkgConfigDb       <- readPkgConfigDb      verbosity conf +  checkConfigExFlags verbosity installedPkgIndex+                     (packageIndex sourcePkgDb) configExFlags+   progress <- planLocalPackage verbosity comp platform configFlags configExFlags-                               installedPkgIndex sourcePkgDb+                               installedPkgIndex sourcePkgDb pkgConfigDb    notice verbosity "Resolving dependencies..."   maybePlan <- foldProgress logMsg (return . Left) (return . Right)                             progress   case maybePlan of     Left message -> do-      info verbosity message-      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing-        configureCommand (const configFlags) extraArgs+      warn verbosity $+           "solver failed to find a solution:\n"+        ++ message+        ++ "Trying configure anyway."+      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)+        Nothing configureCommand (const configFlags) extraArgs      Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->+      [pkg@(ReadyPackage+             (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)+                                 _ _ _)+             _)] -> do         configurePackage verbosity-          (InstallPlan.planPlatform installPlan)-          (InstallPlan.planCompiler installPlan)-          (setupScriptOptions installedPkgIndex)+          platform (compilerInfo comp)+          (setupScriptOptions installedPkgIndex (Just pkg))           configFlags pkg extraArgs        _ -> die $ "internal error: configure install plan should have exactly "               ++ "one local ready package."    where-    setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = chooseCabalVersion configExFlags-                         (flagToMaybe (configCabalVersion configExFlags)),-      useCompiler      = Just comp,-      usePlatform      = Just platform,-      usePackageDB     = packageDBs',-      usePackageIndex  = index',-      useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing,-      useWin32CleanHack        = False,-      forceExternalSetupMethod = False,-      setupCacheLock   = Nothing-    }-      where-        -- Hack: we typically want to allow the UserPackageDB for finding the-        -- Cabal lib when compiling any Setup.hs even if we're doing a global-        -- install. However we also allow looking in a specific package db.-        (packageDBs', index') =-          case packageDBs of-            (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs-                -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)-            -- but if the user is using an odd db stack, don't touch it-            dbs -> (dbs, Just index)+    setupScriptOptions :: InstalledPackageIndex+                       -> Maybe ReadyPackage+                       -> SetupScriptOptions+    setupScriptOptions =+      configureSetupScript+        packageDBs+        comp+        platform+        conf+        (fromFlagOrDefault+           (useDistPref defaultSetupScriptOptions)+           (configDistPref configFlags))+        (chooseCabalVersion+           configFlags+           (flagToMaybe (configCabalVersion configExFlags)))+        Nothing+        False      logMsg message rest = debug verbosity message >> rest +configureSetupScript :: PackageDBStack+                     -> Compiler+                     -> Platform+                     -> ProgramConfiguration+                     -> FilePath+                     -> VersionRange+                     -> Maybe Lock+                     -> Bool+                     -> InstalledPackageIndex+                     -> Maybe ReadyPackage+                     -> SetupScriptOptions+configureSetupScript packageDBs+                     comp+                     platform+                     conf+                     distPref+                     cabalVersion+                     lock+                     forceExternal+                     index+                     mpkg+  = SetupScriptOptions {+      useCabalVersion          = cabalVersion+    , useCabalSpecVersion      = Nothing+    , useCompiler              = Just comp+    , usePlatform              = Just platform+    , usePackageDB             = packageDBs'+    , usePackageIndex          = index'+    , useProgramConfig         = conf+    , useDistPref              = distPref+    , useLoggingHandle         = Nothing+    , useWorkingDir            = Nothing+    , setupCacheLock           = lock+    , useWin32CleanHack        = False+    , forceExternalSetupMethod = forceExternal+      -- If we have explicit setup dependencies, list them; otherwise, we give+      -- the empty list of dependencies; ideally, we would fix the version of+      -- Cabal here, so that we no longer need the special case for that in+      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet+      -- know the version of Cabal at this point, but only find this there.+      -- Therefore, for now, we just leave this blank.+    , useDependencies          = fromMaybe [] explicitSetupDeps+    , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps+    , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps+    }+  where+    -- When we are compiling a legacy setup script without an explicit+    -- setup stanza, we typically want to allow the UserPackageDB for+    -- finding the Cabal lib when compiling any Setup.hs even if we're doing+    -- a global install. However we also allow looking in a specific package+    -- db.+    packageDBs' :: PackageDBStack+    index'      :: Maybe InstalledPackageIndex+    (packageDBs', index') =+      case packageDBs of+        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs+                              , Nothing <- explicitSetupDeps+            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)+        -- but if the user is using an odd db stack, don't touch it+        _otherwise -> (packageDBs, Just index)++    maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo+    maybeSetupBuildInfo = do+      ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) _+                 <- mpkg+      PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)++    -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If+    -- so, 'setup-depends' must not be exclusive. See #3199.+    defaultSetupDeps :: Bool+    defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends+                       maybeSetupBuildInfo++    explicitSetupDeps :: Maybe [(UnitId, 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+             ]++-- | Warn if any constraints or preferences name packages that are not in the+-- source package index or installed package index.+checkConfigExFlags :: Package pkg+                   => Verbosity+                   -> InstalledPackageIndex+                   -> PackageIndex pkg+                   -> ConfigExFlags+                   -> IO ()+checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do+  unless (null unknownConstraints) $ warn verbosity $+             "Constraint refers to an unknown package: "+          ++ showConstraint (head unknownConstraints)+  unless (null unknownPreferences) $ warn verbosity $+             "Preference refers to an unknown package: "+          ++ display (head unknownPreferences)+  where+    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $+                         configExConstraints flags+    unknownPreferences = filter (unknown . \(Dependency name _) -> name) $+                         configPreferences flags+    unknown pkg = null (lookupPackageName installedPkgIndex pkg)+               && not (elemByPackageName sourcePkgIndex pkg)+    showConstraint (uc, src) =+        display uc ++ " (" ++ showConstraintSource src ++ ")"+ -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. --@@ -154,11 +283,13 @@                  -> ConfigFlags -> ConfigExFlags                  -> InstalledPackageIndex                  -> SourcePackageDb+                 -> PkgConfigDb                  -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex-  (SourcePackageDb _ packagePrefs) = do+planLocalPackage verbosity comp platform configFlags configExFlags+  installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity-  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp)+  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)+            (compilerInfo comp)    let -- We create a local package and ask to resolve a dependency on it       localPkg = SourcePackage {@@ -173,8 +304,8 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =-          removeUpperBounds (fromFlagOrDefault AllowNewerNone $-                             configAllowNewer configExFlags)+          removeUpperBounds+          (fromMaybe AllowNewerNone $ configAllowNewer configFlags)          . addPreferences             -- preferences from the config file or command line@@ -185,19 +316,23 @@             -- version constraints from the config file or command line             -- TODO: should warn or error on constraints that are not on direct             -- deps or flag constraints not on the package in question.-            (map userToPackageConstraint (configExConstraints configExFlags))+            [ LabeledPackageConstraint (userToPackageConstraint uc) src+            | (uc, src) <- configExConstraints configExFlags ]          . addConstraints             -- package flags from the config file or command line-            [ PackageConstraintFlags (packageName pkg)-                                     (configConfigurationsFlags configFlags) ]+            [ let pc = PackageConstraintFlags (packageName pkg)+                       (configConfigurationsFlags configFlags)+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+            ]          . addConstraints             -- '--enable-tests' and '--enable-benchmarks' constraints from-            -- command line-            [ PackageConstraintStanzas (packageName pkg) $-                [ TestStanzas  | testsEnabled ] ++-                [ BenchStanzas | benchmarksEnabled ]+            -- the config file or command line+            [ let pc = PackageConstraintStanzas (packageName pkg) $+                       [ TestStanzas  | testsEnabled ] +++                       [ BenchStanzas | benchmarksEnabled ]+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget             ]          $ standardInstallPolicy@@ -205,7 +340,7 @@             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies platform (compilerInfo comp) solver resolverParams)+  return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)   -- | Call an installer for an 'SourcePackage' but override the configure@@ -224,7 +359,10 @@                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-  (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =+                 (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)+                                                  flags stanzas _)+                               deps)+                 extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -236,10 +374,10 @@       -- deps.  In the end only one set gets passed to Setup.hs configure,       -- depending on the Cabal version we are talking to.       configConstraints  = [ thisPackageVersion (packageId deppkg)-                           | deppkg <- deps ],+                           | deppkg <- CD.nonSetupDeps deps ],       configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                              Installed.installedPackageId deppkg)-                           | deppkg <- deps ],+                              Installed.installedUnitId deppkg)+                           | deppkg <- CD.nonSetupDeps deps ],       -- Use '--exact-configuration' if supported.       configExactConfiguration = toFlag True,       configVerbosity          = toFlag verbosity,
Distribution/Client/Dependency.hs view
@@ -53,10 +53,11 @@     setStrongFlags,     setMaxBackjumps,     addSourcePackages,-    hideInstalledPackagesSpecificByInstalledPackageId,+    hideInstalledPackagesSpecificByUnitId,     hideInstalledPackagesSpecificBySourcePackageId,     hideInstalledPackagesAllVersions,-    removeUpperBounds+    removeUpperBounds,+    addDefaultSetupDependencies,   ) where  import Distribution.Client.Dependency.TopDown@@ -68,47 +69,66 @@ 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.Types-         ( SourcePackageDb(SourcePackageDb)-         , SourcePackage(..) )+         ( SourcePackageDb(SourcePackageDb), SourcePackage(..)+         , ConfiguredPackage(..), ConfiguredId(..)+         , OptionalStanza(..), enableStanzas ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)-         , debugPackageConstraint-         , AllowNewer(..), PackagePreferences(..), InstalledPreference(..)+         ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)+         , PackageConstraint(..), showPackageConstraint+         , LabeledPackageConstraint(..), unlabelPackageConstraint+         , ConstraintSource(..), showConstraintSource+         , PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress ) 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(..), PackageId, Package(..), packageName, packageVersion-         , InstalledPackageId, Dependency(Dependency))+         ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId+         , Package(..), packageName, packageVersion+         , UnitId, Dependency(Dependency)) import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), GenericPackageDescription(..)-         , Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)-import Distribution.PackageDescription (BuildInfo(targetBuildDepends))-import Distribution.PackageDescription.Configuration (mapCondTree)+import qualified Distribution.PackageDescription.Configuration as PD+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Client.PackageUtils+         ( externalBuildDepends ) import Distribution.Version-         ( Version(..), VersionRange, anyVersion, thisVersion, withinRange-         , removeUpperBound, simplifyVersionRange )+         ( VersionRange, Version(..), anyVersion, orLaterVersion, thisVersion+         , withinRange, simplifyVersionRange ) import Distribution.Compiler-         ( CompilerId(..), CompilerInfo(..), CompilerFlavor(..) )+         ( CompilerInfo(..) ) import Distribution.System          ( Platform )+import Distribution.Client.Utils+         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing, warn, info )+import Distribution.Simple.Configure+         ( relaxPackageDeps )+import Distribution.Simple.Setup+         ( AllowNewer(..) ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( Verbosity ) -import Data.List (maximumBy, foldl', intercalate)-import Data.Maybe (fromMaybe)+import Data.List+         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )+import Data.Function (on)+import Data.Maybe  (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)+import Control.Exception+         ( assert ) + -- ------------------------------------------------------------ -- * High level planner policy -- ------------------------------------------------------------@@ -119,7 +139,7 @@ -- data DepResolverParams = DepResolverParams {        depResolverTargets           :: [PackageName],-       depResolverConstraints       :: [PackageConstraint],+       depResolverConstraints       :: [LabeledPackageConstraint],        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,        depResolverInstalledPkgIndex :: InstalledPackageIndex,@@ -132,14 +152,27 @@        depResolverMaxBackjumps      :: Maybe Int      } -debugDepResolverParams :: DepResolverParams -> String-debugDepResolverParams p =+showDepResolverParams :: DepResolverParams -> String+showDepResolverParams p =      "targets: " ++ intercalate ", " (map display (depResolverTargets p))   ++ "\nconstraints: "-  ++   concatMap (("\n  " ++) . debugPackageConstraint) (depResolverConstraints p)+  ++   concatMap (("\n  " ++) . showLabeledConstraint)+       (depResolverConstraints p)   ++ "\npreferences: "-  ++   concatMap (("\n  " ++) . debugPackagePreference) (depResolverPreferences p)-  ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)+  ++   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)+  ++ "\nmax backjumps: "     ++ maybe "infinite" show+                                     (depResolverMaxBackjumps      p)+  where+    showLabeledConstraint :: LabeledPackageConstraint -> String+    showLabeledConstraint (LabeledPackageConstraint pc src) =+        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"  -- | A package selection preference for a particular package. --@@ -155,14 +188,21 @@      -- | If we prefer versions of packages that are already installed.    | PackageInstalledPreference PackageName InstalledPreference +     -- | If we would prefer to enable these optional stanzas+     -- (i.e. test suites and/or benchmarks)+   | PackageStanzasPreference   PackageName [OptionalStanza]++ -- | Provide a textual representation of a package preference -- for debugging purposes. ---debugPackagePreference :: PackagePreference -> String-debugPackagePreference (PackageVersionPreference   pn vr) =+showPackagePreference :: PackagePreference -> String+showPackagePreference (PackageVersionPreference   pn vr) =   display pn ++ " " ++ display (simplifyVersionRange vr)-debugPackagePreference (PackageInstalledPreference pn ip) =+showPackagePreference (PackageInstalledPreference pn ip) =   display pn ++ " " ++ show ip+showPackagePreference (PackageStanzasPreference pn st) =+  display pn ++ " " ++ show st  basicDepResolverParams :: InstalledPackageIndex                        -> PackageIndex.PackageIndex SourcePackage@@ -190,7 +230,7 @@       depResolverTargets = extraTargets ++ depResolverTargets params     } -addConstraints :: [PackageConstraint]+addConstraints :: [LabeledPackageConstraint]                -> DepResolverParams -> DepResolverParams addConstraints extraConstraints params =     params {@@ -256,8 +296,10 @@     addConstraints extraConstraints params   where     extraConstraints =-      [ PackageConstraintInstalled pkgname-      | all (/=PackageName "base") (depResolverTargets params)+      [ LabeledPackageConstraint+        (PackageConstraintInstalled pkgname)+        ConstraintSourceNonUpgradeablePackage+      | notElem (PackageName "base") (depResolverTargets params)       , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"                                    , "integer-simple" ]       , isInstalled pkgname ]@@ -277,14 +319,14 @@               (depResolverSourcePkgIndex params) pkgs     } -hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]+hideInstalledPackagesSpecificByUnitId :: [UnitId]                                                      -> DepResolverParams                                                      -> DepResolverParams-hideInstalledPackagesSpecificByInstalledPackageId pkgids params =+hideInstalledPackagesSpecificByUnitId pkgids params =     --TODO: this should work using exclude constraints instead     params {       depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)+        foldl' (flip InstalledPackageIndex.deleteUnitId)                (depResolverInstalledPkgIndex params) pkgids     } @@ -312,96 +354,71 @@  hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams hideBrokenInstalledPackages params =-    hideInstalledPackagesSpecificByInstalledPackageId pkgids params+    hideInstalledPackagesSpecificByUnitId pkgids params   where-    pkgids = map Installed.installedPackageId+    pkgids = map Installed.installedUnitId            . InstalledPackageIndex.reverseDependencyClosure                             (depResolverInstalledPkgIndex params)-           . map (Installed.installedPackageId . fst)+           . map (Installed.installedUnitId . fst)            . InstalledPackageIndex.brokenPackages            $ depResolverInstalledPkgIndex params  -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none).+--+-- Note: It's important to apply 'removeUpperBounds' after+-- 'addSourcePackages'. Otherwise, the packages inserted by+-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.+-- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds allowNewer params =+removeUpperBounds AllowNewerNone params = params+removeUpperBounds allowNewer     params =     params {-      -- NB: It's important to apply 'removeUpperBounds' after-      -- 'addSourcePackages'. Otherwise, the packages inserted by-      -- 'addSourcePackages' won't have upper bounds in dependencies relaxed.-       depResolverSourcePkgIndex = sourcePkgIndex'     }   where-    sourcePkgIndex  = depResolverSourcePkgIndex params-    sourcePkgIndex' = case allowNewer of-      AllowNewerNone      -> sourcePkgIndex-      AllowNewerAll       -> fmap relaxAllPackageDeps         sourcePkgIndex-      AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex--    relaxAllPackageDeps :: SourcePackage -> SourcePackage-    relaxAllPackageDeps = onAllBuildDepends doRelax-      where-        doRelax (Dependency pkgName verRange) =-          Dependency pkgName (removeUpperBound verRange)--    relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage-    relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax-      where-        doRelax d@(Dependency pkgName verRange)-          | pkgName `elem` pkgNames = Dependency pkgName-                                      (removeUpperBound verRange)-          | otherwise               = d--    -- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'-    -- fields.-    onAllBuildDepends :: (Dependency -> Dependency)-                      -> SourcePackage -> SourcePackage-    onAllBuildDepends f srcPkg = srcPkg'-      where-        gpd        = packageDescription srcPkg-        pd         = PD.packageDescription gpd-        condLib    = PD.condLibrary        gpd-        condExes   = PD.condExecutables    gpd-        condTests  = PD.condTestSuites     gpd-        condBenchs = PD.condBenchmarks     gpd--        f' = onBuildInfo f-        onBuildInfo g bi = bi-          { targetBuildDepends = map g (targetBuildDepends bi) }+    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params -        onLibrary    lib  = lib { PD.libBuildInfo  = f' $ PD.libBuildInfo  lib }-        onExecutable exe  = exe { PD.buildInfo     = f' $ PD.buildInfo     exe }-        onTestSuite  tst  = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }-        onBenchmark  bmk  = bmk { PD.benchmarkBuildInfo =-                                     f' $ PD.benchmarkBuildInfo bmk }+    relaxDeps :: SourcePackage -> SourcePackage+    relaxDeps srcPkg = srcPkg {+      packageDescription = relaxPackageDeps allowNewer+                           (packageDescription srcPkg)+      } -        srcPkg' = srcPkg { packageDescription = gpd' }-        gpd'    = gpd {-          PD.packageDescription = pd',-          PD.condLibrary        = condLib',-          PD.condExecutables    = condExes',-          PD.condTestSuites     = condTests',-          PD.condBenchmarks     = condBenchs'-          }-        pd' = pd {-          PD.buildDepends = map  f            (PD.buildDepends pd),-          PD.library      = fmap onLibrary    (PD.library pd),-          PD.executables  = map  onExecutable (PD.executables pd),-          PD.testSuites   = map  onTestSuite  (PD.testSuites pd),-          PD.benchmarks   = map  onBenchmark  (PD.benchmarks pd)+-- | 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])+                            -> DepResolverParams -> DepResolverParams+addDefaultSetupDependencies defaultSetupDeps params =+    params {+      depResolverSourcePkgIndex =+        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)+    }+  where+    applyDefaultSetupDeps :: SourcePackage -> SourcePackage+    applyDefaultSetupDeps srcpkg =+        srcpkg {+          packageDescription = gpkgdesc {+            PD.packageDescription = pkgdesc {+              PD.setupBuildInfo =+                case PD.setupBuildInfo pkgdesc of+                  Just sbi -> Just sbi+                  Nothing  -> case defaultSetupDeps srcpkg of+                    Nothing -> Nothing+                    Just deps -> Just PD.SetupBuildInfo {+                      PD.defaultSetupDepends = True,+                      PD.setupDepends        = deps+                    }+            }           }-        condLib'    = fmap (onCondTree onLibrary)             condLib-        condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes-        condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests-        condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs--        mapSnd :: (a -> b) -> (c,a) -> (c,b)-        mapSnd = fmap--        onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a-                   -> PD.CondTree v [Dependency] b-        onCondTree g = mapCondTree g (map f) id+        }+      where+        gpkgdesc = packageDescription srcpkg+        pkgdesc  = PD.packageDescription gpkgdesc   upgradeDependencies :: DepResolverParams -> DepResolverParams@@ -434,12 +451,41 @@   . hideInstalledPackagesSpecificBySourcePackageId       [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] +  . addDefaultSetupDependencies mkDefaultSetupDeps+   . addSourcePackages       [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]    $ basicDepResolverParams       installedPkgIndex sourcePkgIndex +    where+      -- Force Cabal >= 1.24 dep when the package is affected by #3199.+      mkDefaultSetupDeps :: SourcePackage -> Maybe [Dependency]+      mkDefaultSetupDeps srcpkg | affected        =+        Just [Dependency (PackageName "Cabal")+              (orLaterVersion $ Version [1,24] [])]+                                | otherwise       = Nothing+        where+          gpkgdesc = packageDescription srcpkg+          pkgdesc  = PD.packageDescription gpkgdesc+          bt       = fromMaybe PD.Custom (PD.buildType pkgdesc)+          affected = bt == PD.Custom && hasBuildableFalse gpkgdesc++      -- Does this package contain any components with non-empty 'build-depends'+      -- and a 'buildable' field that could potentially be set to 'False'? False+      -- positives are possible.+      hasBuildableFalse :: PD.GenericPackageDescription -> Bool+      hasBuildableFalse gpkg =+        not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))+        where+          buildableConditions      = PD.extractConditions PD.buildable gpkg+          noDepConditions          = PD.extractConditions+                                     (null . PD.targetBuildDepends)    gpkg+          alwaysTrue (PD.Lit True) = True+          alwaysTrue _             = False++ applySandboxInstallPolicy :: SandboxPackageInfo                              -> DepResolverParams                              -> DepResolverParams@@ -457,8 +503,10 @@         (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]    . addConstraints-      [ PackageConstraintVersion (packageName pkg)-        (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]+      [ let pc = PackageConstraintVersion (packageName pkg)+                 (thisVersion (packageVersion pkg))+        in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep+      | pkg <- modifiedDeps ]    . addTargets [ packageName pkg | pkg <- modifiedDeps ] @@ -483,16 +531,16 @@ -- ------------------------------------------------------------  chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver-chooseSolver _         AlwaysTopDown _                = return TopDown-chooseSolver _         AlwaysModular _                = return Modular-chooseSolver verbosity Choose        cinfo            = do-  let (CompilerId f v) = compilerInfoId cinfo-      chosenSolver | f == GHC && v <= Version [7] [] = TopDown-                   | otherwise                       = Modular-      msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."-      msg Modular = info verbosity "Choosing modular solver."-  msg chosenSolver-  return chosenSolver+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@@ -506,23 +554,26 @@ -- resolveDependencies :: Platform                     -> CompilerInfo+                    -> PkgConfigDb                     -> Solver                     -> DepResolverParams                     -> Progress String String InstallPlan      --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages-resolveDependencies platform comp _solver params+resolveDependencies platform comp _pkgConfigDB _solver params   | null (depResolverTargets params)-  = return (mkInstallPlan platform comp [])+  = return (validateSolverResult platform comp indGoals [])+  where+    indGoals = depResolverIndependentGoals params -resolveDependencies platform comp  solver params =+resolveDependencies platform comp pkgConfigDB solver params = -    Step (debugDepResolverParams finalparams)-  $ fmap (mkInstallPlan platform comp)+    Step (showDepResolverParams finalparams)+  $ fmap (validateSolverResult platform comp indGoals)   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls                       shadowing strFlags maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex-                     preferences constraints targets+                     pkgConfigDB preferences constraints targets   where      finalparams @ (DepResolverParams@@ -548,24 +599,7 @@     preferences = interpretPackagesPreference                     (Set.fromList targets) defpref prefs --- | Make an install plan from the output of the dep resolver.--- It checks that the plan is valid, or it's an error in the dep resolver.----mkInstallPlan :: Platform-              -> CompilerInfo-              -> [InstallPlan.PlanPackage] -> InstallPlan-mkInstallPlan platform comp pkgIndex =-  let index = InstalledPackageIndex.fromList pkgIndex in-  case InstallPlan.new platform comp index of-    Right plan     -> plan-    Left  problems -> error $ unlines $-        "internal error: could not construct a valid install plan."-      : "The proposed (invalid) plan contained the following problems:"-      : map InstallPlan.showPlanProblem problems-      ++ "Proposed plan:"-      : [InstallPlan.showPlanIndex index] - -- | Give an interpretation to the global 'PackagesPreference' as --  specific per-package 'PackageVersionPreference'. --@@ -574,14 +608,15 @@                             -> [PackagePreference]                             -> (PackageName -> PackagePreferences) interpretPackagesPreference selected defaultPref prefs =-  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)-+  \pkgname -> PackagePreferences (versionPref pkgname)+                                 (installPref pkgname)+                                 (stanzasPref pkgname)   where     versionPref pkgname =-      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)-    versionPrefs = Map.fromList-      [ (pkgname, pref)-      | PackageVersionPreference pkgname pref <- prefs ]+      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromListWith (++)+                   [(pkgname, [pref])+                   | PackageVersionPreference pkgname pref <- prefs]      installPref pkgname =       fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)@@ -589,15 +624,181 @@       [ (pkgname, pref)       | PackageInstalledPreference pkgname pref <- prefs ]     installPrefDefault = case defaultPref of-      PreferAllLatest         -> \_       -> PreferLatest-      PreferAllInstalled      -> \_       -> PreferInstalled+      PreferAllLatest         -> const PreferLatest+      PreferAllInstalled      -> const PreferInstalled       PreferLatestForSelected -> \pkgname ->         -- When you say cabal install foo, what you really mean is, prefer the         -- latest version of foo, but the installed version of everything else         if pkgname `Set.member` selected then PreferLatest                                          else PreferInstalled +    stanzasPref pkgname =+      fromMaybe [] (Map.lookup pkgname stanzasPrefs)+    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))+      [ (pkgname, pref)+      | PackageStanzasPreference pkgname pref <- prefs ]++ -- ------------------------------------------------------------+-- * Checking the result of the solver+-- ------------------------------------------------------------++-- | Make an install plan from the output of the dep resolver.+-- It checks that the plan is valid, or it's an error in the dep resolver.+--+validateSolverResult :: Platform+                     -> CompilerInfo+                     -> Bool+                     -> [ResolverPackage]+                     -> InstallPlan+validateSolverResult platform comp indepGoals pkgs =+    case planPackagesProblems platform comp pkgs of+      [] -> case InstallPlan.new indepGoals index 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++    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem+    formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem++    formatProblemMessage problems =+      unlines $+        "internal error: could not construct a valid install plan."+      : "The proposed (invalid) plan contained the following problems:"+      : problems+      ++ "Proposed plan:"+      : [InstallPlan.showPlanIndex index]+++data PlanPackageProblem =+       InvalidConfiguredPackage ConfiguredPackage [PackageProblem]++showPlanPackageProblem :: PlanPackageProblem -> String+showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =+     "Package " ++ display (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]++planPackagesProblems :: Platform -> CompilerInfo+                     -> [ResolverPackage]+                     -> [PlanPackageProblem]+planPackagesProblems platform cinfo pkgs =+     [ InvalidConfiguredPackage pkg packageProblems+     | Configured pkg <- pkgs+     , let packageProblems = configuredPackageProblems platform cinfo pkg+     , not (null packageProblems) ]++data PackageProblem = DuplicateFlag PD.FlagName+                    | MissingFlag   PD.FlagName+                    | ExtraFlag     PD.FlagName+                    | DuplicateDeps [PackageId]+                    | MissingDep    Dependency+                    | ExtraDep      PackageId+                    | InvalidDep    Dependency PackageId++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag (PD.FlagName flag)) =+  "duplicate flag in the flag assignment: " ++ flag++showPackageProblem (MissingFlag (PD.FlagName flag)) =+  "missing an assignment for the flag: " ++ flag++showPackageProblem (ExtraFlag (PD.FlagName flag)) =+  "extra flag given that is not used by the package: " ++ flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map display pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ display dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ display pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ display dep+  ++ " but the configuration specifies " ++ display pkgid+  ++ " which does not satisfy the dependency."++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- in the configuration given by the flag assignment, all the package+-- dependencies are satisfied by the specified packages.+--+configuredPackageProblems :: Platform -> CompilerInfo+                          -> ConfiguredPackage -> [PackageProblem]+configuredPackageProblems platform cinfo+  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =+     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))+                                specifiedDeps) ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  where+    specifiedDeps :: ComponentDeps [PackageId]+    specifiedDeps = fmap (map confSrcId) specifiedDeps'++    mergedFlags = mergeBy compare+      (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))+      (sort $ map fst specifiedFlags)++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _) = name++    mergedDeps :: [MergeResult Dependency PackageId]+    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)++    mergeDeps :: [Dependency] -> [PackageId]+              -> [MergeResult Dependency PackageId]+    mergeDeps required specified =+      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in+      mergeBy+        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+        (sortNubOn dependencyName required)+        (sortNubOn packageName    specified)++    -- TODO: It would be nicer to use ComponentDeps here so we can be more+    -- precise in our checks. That's a bit tricky though, as this currently+    -- relies on the 'buildDepends' field of 'PackageDescription'. (OTOH, that+    -- field is deprecated and should be removed anyway.)  As long as we _do_+    -- use a flat list here, we have to allow for duplicates when we fold+    -- specifiedDeps; once we have proper ComponentDeps here we should get rid+    -- of the `nubOn` in `mergeDeps`.+    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePackageDescription+      case finalizePackageDescription specifiedFlags+         (const True)+         platform cinfo+         []+         (enableStanzas stanzas $ packageDescription pkg) of+        Right (resolvedPkg, _) ->+             externalBuildDepends resolvedPkg+          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)+        Left  _ ->+          error "configuredPackageInvalidDeps internal error"+++-- ------------------------------------------------------------ -- * Simple resolver that ignores dependencies -- ------------------------------------------------------------ @@ -636,7 +837,7 @@                                                          pkgDependency          -- Preferences-        PackagePreferences preferredVersions preferInstalled+        PackagePreferences preferredVersions preferInstalled _           = packagePreferences pkgname          bestByPrefs   = comparing $ \pkg ->@@ -647,14 +848,16 @@                            . InstalledPackageIndex.lookupSourcePackageId                                                      installedPkgIndex                            . packageId-        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions+        versionPref pkg = length . filter (packageVersion pkg `withinRange`) $+                          preferredVersions      packageConstraints :: PackageName -> VersionRange     packageConstraints pkgname =       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap     packageVersionConstraintMap =-      Map.fromList [ (name, range)-                   | PackageConstraintVersion name range <- constraints ]+      let pcs = map unlabelPackageConstraint constraints+      in Map.fromList [ (name, range)+                      | PackageConstraintVersion name range <- pcs ]      packagePreferences :: PackageName -> PackagePreferences     packagePreferences = interpretPackagesPreference
Distribution/Client/Dependency/Modular.hs view
@@ -26,27 +26,28 @@ import Distribution.Client.Dependency.Modular.Solver          ( SolverConfig(..), solve ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..) )-import Distribution.Client.InstallPlan-         ( PlanPackage )+         ( 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 pprefs pcs pns =+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 idx pprefs gcs pns+  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 (\ pc -> (pcName pc, [pc])) pcs)+      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 -> [PlanPackage]+      postprocess :: Assignment -> RevDepMap -> [ResolverPackage]       postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)        -- Helper function to extract the PN from a constraint.
Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -1,4 +1,11 @@-module Distribution.Client.Dependency.Modular.Assignment where+module Distribution.Client.Dependency.Modular.Assignment+    ( Assignment(..)+    , FAssignment+    , SAssignment+    , PreAssignment(..)+    , extend+    , toCPs+    ) where  import Control.Applicative import Control.Monad@@ -6,16 +13,19 @@ import Data.List as L import Data.Map as M import Data.Maybe-import Data.Graph 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.Index import Distribution.Client.Dependency.Modular.Package import Distribution.Client.Dependency.Modular.Version @@ -51,21 +61,38 @@ -- -- Either returns a witness of the conflict that would arise during the merge, -- or the successfully extended assignment.-extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-extend var pa qa = foldM (\ 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)-                    pa qa+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 _ (Goal var' _)) c | v == var && var' == var = [c]-    simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]-    simplify _ c                       d                           = [c, d]+    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. --@@ -77,13 +104,13 @@ toCPs (A pa fa sa) rdm =   let     -- get hold of the graph-    g   :: Graph-    vm  :: Vertex -> ((), QPN, [QPN])+    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+    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@@ -106,49 +133,18 @@            M.toList $            sa     -- Dependencies per package.-    depp :: QPN -> [PI QPN]+    depp :: QPN -> [(Component, PI QPN)]     depp qpn = let v :: Vertex                    v   = fromJust (cvm qpn)-                   dvs :: [Vertex]+                   dvs :: [(Component, Vertex)]                    dvs = tg A.! v-               in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs+               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))+                                 (depp' qpn))           ps---- | Finalize an assignment and a reverse dependency map.------ This is preliminary, and geared towards output right now.-finalize :: Index -> Assignment -> RevDepMap -> IO ()-finalize idx (A pa fa _) rdm =-  let-    -- get hold of the graph-    g  :: Graph-    vm :: Vertex -> ((), QPN, [QPN])-    (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))-    -- topsort the dependency graph, yielding a list of pkgs in the right order-    f :: [PI QPN]-    f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g))-    fapp :: Map QPN [(QFN, Bool)] -- flags per package-    fapp = M.fromListWith (++) $-           L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa-    -- print one instance-    ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp)-    -- print install status-    status :: PI QPN -> String-    status (PI (Q _ pn) _) =-      case insts of-        [] -> " (new)"-        vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")"-      where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $-                    M.keys (M.findWithDefault M.empty pn idx)-            isInstalled (I _ (Inst _ )) = True-            isInstalled _               = False-    -- print flag assignment-    pflags = unwords . L.map (uncurry showFBool)-  in-    -- show packages with associated flag assignments-    putStr (unlines (L.map ppi f))
Distribution/Client/Dependency/Modular/Builder.hs view
@@ -1,4 +1,5 @@-module Distribution.Client.Dependency.Modular.Builder where+{-# LANGUAGE CPP #-}+module Distribution.Client.Dependency.Modular.Builder (buildTree) where  -- Building the search tree. --@@ -15,7 +16,6 @@ -- flag-guarded dependencies, we cannot introduce them immediately. Instead, we -- store the entire dependency. -import Control.Monad.Reader hiding (sequence, mapM) import Data.List as L import Data.Map as M import Prelude hiding (sequence, mapM)@@ -24,56 +24,55 @@ import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Index import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+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-  scope :: Scope,           -- ^ information about encapsulations-  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+  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] -> BuildState -> BuildState+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] -> BuildState-    go g o []                                             = s { rdeps = g, open = o }-    go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs+    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 _)) _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 (qpn':) qpn g)             o  ngs-      | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs-                                       -- code above is correct; insert/adjust have different arg order+    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 --- | Update the current scope by taking into account the encapsulations that--- are defined for the current package.-establishScope :: QPN -> Encaps -> BuildState -> BuildState-establishScope (Q pp pn) ecs s =-    s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }-  where-    pp' = pn : pp -- new path+    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 -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->+scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->                     BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s   where-    sc     = scope s     -- Qualify all package names-    qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names+    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@@ -97,14 +96,14 @@ -- | Datatype that encodes what to build next data BuildType =     Goals                                  -- ^ build a goal choice node-  | OneGoal OpenGoal                       -- ^ build a node for this goal-  | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance+  | 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 (QGoalReasonChain, Scope)+build :: BuildState -> Tree QGoalReason build = ana go   where-    go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState+    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@@ -119,11 +118,22 @@     --     -- For a package, we look up the instances available in the global info,     -- and then handle each instance in turn.-    go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =+    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  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)-        Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) ->-                                                           (i, bs { next = Instance qpn i info gr }))+        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 @@ -131,19 +141,24 @@     -- that is indicated by the flag default.     --     -- TODO: Should we include the flag default in the tree?-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =-      FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b-        [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),-         (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))+    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 -    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =-      SChoiceF qsn (gr, sc) trivial (P.fromList-        [(False,                                                                        bs  { next = Goals }),-         (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })])+    -- 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 @@ -151,20 +166,23 @@     -- and furthermore we update the set of goals.     --     -- TODO: We could inline this above.-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =-      go ((establishScope qpn ecs-             (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))+    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 (QGoalReasonChain, Scope)+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReason buildTree idx ind igs =-    build (BS idx sc-                  (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))-                  (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))-                  Goals)+    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-    sc | ind       = makeIndependent igs-       | otherwise = emptyScope-    qpns           = L.map (qualify sc) igs+    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 view
@@ -1,10 +1,13 @@-module Distribution.Client.Dependency.Modular.Configured where+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] [PI qpn]+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view
@@ -1,40 +1,54 @@-module Distribution.Client.Dependency.Modular.ConfiguredConversion where+module Distribution.Client.Dependency.Modular.ConfiguredConversion+    ( convCP+    ) where  import Data.Maybe import Prelude hiding (pi) -import Distribution.Client.InstallPlan+import Distribution.Package (UnitId)+ import Distribution.Client.Types-import Distribution.Compiler+import Distribution.Client.Dependency.Types (ResolverPackage(..)) import qualified Distribution.Client.PackageIndex as CI import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System  import Distribution.Client.Dependency.Modular.Configured import Distribution.Client.Dependency.Modular.Package -mkPlan :: Platform -> CompilerInfo ->-          SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->-          [CP QPN] -> Either [PlanProblem] InstallPlan-mkPlan plat comp iidx sidx cps =-  new plat comp (SI.fromList (map (convCP iidx sidx) cps))+import Distribution.Client.ComponentDeps (ComponentDeps) -convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->-          CP QPN -> PlanPackage+-- | 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 $ InstalledPackage-                  (fromJust $ SI.lookupInstalledPackageId iidx pi)-                  (map convPI' ds)+    Left  pi -> PreExisting+                  (fromJust $ SI.lookupUnitId iidx pi)     Right pi -> Configured $ ConfiguredPackage-                  (fromJust $ CI.lookupPackageId sidx pi)+                  srcpkg                   fa                   es-                  (map convPI' ds)+                  ds'+      where+        Just srcpkg = CI.lookupPackageId sidx pi+  where+    ds' :: ComponentDeps [ConfiguredId]+    ds' = fmap (map convConfId) ds -convPI :: PI QPN -> Either InstalledPackageId PackageId+convPI :: PI QPN -> Either UnitId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi-convPI qpi                    = Right $ convPI' qpi+convPI qpi                    = Right $ confSrcId $ convConfId qpi -convPI' :: PI QPN -> PackageId-convPI' (PI (Q _ pn) (I v _))  = PackageIdentifier pn v+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 view
@@ -0,0 +1,74 @@+{-# 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 view
@@ -0,0 +1,52 @@+{-# 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 view
@@ -1,65 +1,72 @@ {-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Dependency where+{-# 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.List as L-import Data.Map as M-import Data.Set as S+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---- | 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.------ TODO: This isn't the ideal location to declare the type,--- but we need them for constrained instances.-data Var qpn = P qpn | F (FN qpn) | S (SN qpn)-  deriving (Eq, Ord, Show, 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+import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS -type ConflictSet qpn = Set (Var qpn)+import Distribution.Client.ComponentDeps (Component(..)) -showCS :: ConflictSet QPN -> String-showCS = intercalate ", " . L.map showVar . S.toList+{-------------------------------------------------------------------------------+  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 (Goal qpn) | Constrained [VROrigin qpn]+data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]   deriving (Eq, Show, Functor) -instance ResetGoal CI where-  resetGoal g (Fixed i _)       = Fixed i g-  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)--type VROrigin qpn = (VR, Goal 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 (.&&.) anyVR . L.map fst- showCI :: CI QPN -> String showCI (Fixed i _)      = "==" ++ showI i showCI (Constrained vr) = showVR (collapse vr)@@ -81,68 +88,235 @@ 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 (S.union (toConflictSet g1) (toConflictSet g2), (c, d))+  | 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 (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))+      | 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+-------------------------------------------------------------------------------} -type FlaggedDeps qpn = [FlaggedDep qpn]+-- | 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 qpn =+data FlaggedDep comp qpn =     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-  | Simple (Dep qpn)-  deriving (Eq, Show, Functor)+  | Simple (Dep qpn) comp+  deriving (Eq, Show) -type TrueFlaggedDeps  qpn = FlaggedDeps qpn-type FalseFlaggedDeps qpn = FlaggedDeps qpn+-- | 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.-data Dep qpn = Dep qpn (CI qpn)-  deriving (Eq, Show, Functor)+--+-- '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 (Goal v _))          ) =+showDep (Dep qpn (Fixed i v)            ) =   (if P qpn /= v then showVar v ++ " => " else "") ++   showQPN qpn ++ "==" ++ showI i-showDep (Dep qpn (Constrained [(vr, Goal v _)])) =+showDep (Dep qpn (Constrained [(vr, v)])) =   showVar v ++ " => " ++ showQPN qpn ++ showVR vr-showDep (Dep qpn ci                            ) =+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" -instance ResetGoal Dep where-  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)+-- | 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 --- | A map containing reverse dependencies between qualified--- package names.-type RevDepMap = Map QPN [QPN]+    -- Should dependencies of the setup script be treated as independent?+  , qoSetupIndependent :: Bool+  }+  deriving Show --- | Goals are solver variables paired with information about--- why they have been introduced.-data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)-  deriving (Eq, Show, Functor)+-- | 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 -class ResetGoal f where-  resetGoal :: Goal qpn -> f qpn -> f qpn+    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 -instance ResetGoal Goal where-  resetGoal = const+    -- 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) --- | For open goals as they occur during the build phase, we need to store--- additional information about flags.-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain-  deriving (Eq, Show)+    -- 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 --- | Reasons why a goal can be added to a goal set.+    -- 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)@@ -150,32 +324,77 @@   | SDependency (SN qpn)   deriving (Eq, Show, Functor) --- | The first element is the immediate reason. The rest are the reasons--- for the reasons ...-type GoalReasonChain qpn = [GoalReason qpn]+type QGoalReason = GoalReason QPN -type QGoalReasonChain = GoalReasonChain QPN+class ResetVar f where+  resetVar :: Var qpn -> f qpn -> f qpn -goalReasonToVars :: GoalReason qpn -> ConflictSet qpn-goalReasonToVars UserGoal                 = S.empty-goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)-goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn))-goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)+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) -goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn-goalReasonChainToVars = S.unions . L.map goalReasonToVars+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 -goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn-goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars+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 -> Goal QPN-close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr-close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr-close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr+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 --- | Compute a conflic set from a goal. The conflict set contains the--- closure of goal reasons as well as the variable of the goal itself.-toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn-toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)+{-------------------------------------------------------------------------------+  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 view
@@ -1,149 +1,123 @@-module Distribution.Client.Dependency.Modular.Explore where+module Distribution.Client.Dependency.Modular.Explore+    ( backjump+    , backjumpAndExplore+    ) where -import Control.Applicative as A-import Data.Foldable-import Data.List as L+import Data.Foldable as F import Data.Map as M-import Data.Set as S  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 Distribution.Client.Dependency.Modular.PSQ as P+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 --- | Backjumping.+-- | 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. ----- A tree traversal that tries to propagate conflict sets--- up the tree from the leaves, and thereby cut branches.--- All the tricky things are done in the function 'combine'.-backjump :: Tree a -> Tree (Maybe (ConflictSet QPN))-backjump = snd . cata go-  where-    go (FailF c fr) = (Just c, Fail c fr)-    go (DoneF rdm ) = (Nothing, Done rdm)-    go (PChoiceF qpn _     ts) = (c, PChoice qpn c     (P.fromList ts'))-      where-        ~(c, ts') = combine (P qpn) (P.toList ts) S.empty-    go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts'))-      where-        ~(c, ts') = combine (F qfn) (P.toList ts) S.empty-    go (SChoiceF qsn _ b   ts) = (c, SChoice qsn c b   (P.fromList ts'))-      where-        ~(c, ts') = combine (S qsn) (P.toList ts) S.empty-    go (GoalChoiceF        ts) = (c, GoalChoice        (P.fromList ts'))-      where-        ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts-        c          = case cs of []    -> Nothing-                                d : _ -> d---- | The 'combine' function is at the heart of backjumping. It takes--- the variable we're currently considering, and a list of children--- annotated with their respective conflict sets, and an accumulator--- for the result conflict set. It returns a combined conflict set--- for the parent node, and a (potentially shortened) list of children--- with the annotations removed.+-- 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. ----- It is *essential* that we produce the results as early as possible.--- In particular, we have to produce the list of children prior to--- traversing the entire list -- otherwise we lose the desired behaviour--- of being able to traverse the tree from left to right incrementally.+-- 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. ----- We can shorten the list of children 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.+-- 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'. ----- If any of the children might contain a successful solution--- (indicated by Nothing), then Nothing will be the combined--- conflict set. If all children contain conflict sets, we can--- take the union as the combined conflict set.-combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] ->-           ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)])-combine _   []                      c = (Just c, [])-combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $-                                        case d of-                                          Just e | not (simplifyVar var `S.member` e) -> (Just e, [])-                                                 | otherwise                          -> combine var xs (e `S.union` c)-                                          Nothing                                     -> (Nothing, snd $ combine var xs S.empty)---- | Naive backtracking exploration of the search tree. This will yield correct--- assignments only once the tree itself is validated.-explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))-explore = cata go+backjump :: F.Foldable t => Var QPN -> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a+backjump var initial xs = F.foldr combine logBackjump xs initial   where-    go (FailF _ _)           _           = A.empty-    go (DoneF rdm)           a           = pure (a, rdm)-    go (PChoiceF qpn _     ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice-      ts-    go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa (M.insert qfn k fa) sa)) -- record the flag choice-      ts-    go (SChoiceF qsn _ _   ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa fa (M.insert qsn k sa))) -- record the flag choice-      ts-    go (GoalChoiceF        ts) a              =-      casePSQ ts A.empty                      -- empty goal choice is an internal error-        (\ _k v _xs -> v a)                   -- commit to the first goal choice+    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) --- | Version of 'explore' that returns a 'Log'.-exploreLog :: Tree (Maybe (ConflictSet QPN)) ->-              (Assignment -> Log Message (Assignment, RevDepMap))+    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 (FailF c fr)          _           = failWith (Failure c fr)+    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 c     ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    go (PChoiceF qpn gr     ts) (A pa fa sa)   =+      backjump (P qpn) (avoidSet (P qpn) gr) $    -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryP (PI qpn k)) $     -- log and ...+        (\ 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 c _ _ ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    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 c _   ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    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           =-      casePSQ ts-        (failWith (Failure S.empty EmptyGoalChoice))   -- empty goal choice is an internal error+      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 --- | Add in information about pruned trees.+-- | Build a conflict set corresponding to the (virtual) option not to+-- choose a solution for a goal at all. ----- TODO: This isn't quite optimal, because we do not merely report the shape of the--- tree, but rather make assumptions about where that shape originated from. It'd be--- better if the pruning itself would leave information that we could pick up at this--- point.-backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a-backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'!-                           Nothing -> A.empty-                           Just cs -> failWith (Failure cs Backjump)---- | Interface.-exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap)-exploreTree t = explore t (A M.empty M.empty M.empty)+-- 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.-exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap)-exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty)+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 view
@@ -1,5 +1,19 @@ {-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Flag where+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)@@ -12,10 +26,6 @@ -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN (PI qpn) Flag   deriving (Eq, Ord, Show, Functor)---- | Extract the package name from a flag name.-getPN :: FN qpn -> qpn-getPN (FN (PI qpn _) _) = qpn  -- | Flag identifier. Just a string. type Flag = FlagName
Distribution/Client/Dependency/Modular/Index.hs view
@@ -1,4 +1,9 @@-module Distribution.Client.Dependency.Modular.Index where+module Distribution.Client.Dependency.Modular.Index+    ( Index+    , PInfo(..)+    , defaultQualifyOptions+    , mkIndex+    ) where  import Data.List as L import Data.Map as M@@ -9,25 +14,39 @@ 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, encapsulations and failure reasons.+-- 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 PN) FlagInfo Encaps (Maybe FailReason)+data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)   deriving (Show) --- | Encapsulations. A list of package names.-type Encaps = [PN]- 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 view
@@ -1,16 +1,21 @@-module Distribution.Client.Dependency.Modular.IndexConversion where+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 @@ -49,21 +54,21 @@   where      -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))-    shadow x                                     = x--convIPI :: Bool -> SI.InstalledPackageIndex -> Index-convIPI sip = mkIndex . convIPI' sip+    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.installedPackageId 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 fds M.empty [] Nothing)+        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@@ -72,13 +77,13 @@ -- 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 -> InstalledPackageId -> Maybe (FlaggedDep PN)+convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) convIPId pn' idx ipid =-  case SI.lookupInstalledPackageId idx ipid of+  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 (Goal (P pn') []))))+                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.@@ -86,10 +91,6 @@             CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages -convSPI :: OS -> Arch -> CompilerInfo -> Bool ->-           CI.PackageIndex SourcePackage -> Index-convSPI os arch cinfo strfl = mkIndex . convSPI' os arch cinfo strfl- -- | 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) =@@ -101,28 +102,30 @@ -- want to keep the condition tree, but simplify much of the test.  -- | Convert a generic package description to a solver-specific 'PInfo'.------ TODO: We currently just take all dependencies from all specified library,--- executable and test components. This does not quite seem fair. convGPD :: OS -> Arch -> CompilerInfo -> Bool ->            PI PN -> GenericPackageDescription -> PInfo-convGPD os arch comp strfl pi-        (GenericPackageDescription _ flags libs exes tests benchs) =+convGPD os arch cinfo strfl pi+        (GenericPackageDescription pkg flags libs exes tests benchs) =   let-    fds = flagInfo strfl flags+    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 []    (convCondTree os arch comp pi fds (const True)          ) libs    ++-       concatMap   (convCondTree os arch comp pi fds (const True)     . snd) exes    +++      (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     (convCondTree os arch comp pi fds (const True)     . snd) tests)  +++        (L.map     (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)  ++       prefix (Stanza (SN pi BenchStanzas))-        (L.map     (convCondTree os arch comp pi fds (const True)     . snd) benchs))+        (L.map     (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs))       fds-      [] -- TODO: add encaps       Nothing -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn prefix _ []  = [] prefix f fds = [f (concat fds)] @@ -133,12 +136,17 @@  -- | Convert condition trees to flagged dependencies. convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->-                (a -> Bool) -> -- how to detect if a branch is active-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches)-  | p info    = L.map (D.Simple . convDep pn) ds  -- unconditional dependencies-              ++ concatMap (convBranch os arch comp pi fds p) branches-  | otherwise = []+                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. --@@ -150,16 +158,17 @@ -- simple flag choices. convBranch :: OS -> Arch -> CompilerInfo ->               PI PN -> FlagInfo ->-              (a -> Bool) -> -- how to detect if a branch is active+              Component ->+              (a -> BuildInfo) ->               (Condition ConfVar,                CondTree ConfVar [Dependency] a,-               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN-convBranch os arch cinfo pi fds p (c', t', mf') =-  go c' (          convCondTree os arch cinfo pi fds p   t')-        (maybe [] (convCondTree os arch cinfo pi fds p) mf')+               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 PN -> FlaggedDeps PN -> FlaggedDeps PN+          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@@ -188,13 +197,23 @@     -- with deferring flag choices will then usually first resolve this package,     -- and try an already installed version before imposing a default flag choice     -- that might not be what we want.-    extractCommon :: FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN-    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) | D.Simple (Dep pn _) <- ps, D.Simple (Dep pn' _) <- ps', pn == pn' ]+    --+    -- 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, Goal (P pn') [])])+convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, P pn')]) --- | Convert a Cabal package identifier to a solver-specific dependency.-convPI :: PN -> PackageIdentifier -> Dep PN-convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (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 view
@@ -0,0 +1,574 @@+{-# 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 view
@@ -1,8 +1,15 @@-module Distribution.Client.Dependency.Modular.Log where+module Distribution.Client.Dependency.Modular.Log+    ( Log+    , continueWith+    , failWith+    , logToProgress+    , succeedWith+    , tryWith+    ) where  import Control.Applicative import Data.List as L-import Data.Set as S+import Data.Maybe (isNothing)  import Distribution.Client.Dependency.Types -- from Cabal @@ -10,6 +17,7 @@ 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. --@@ -18,104 +26,81 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m () a --- | Turns a log into a list of messages paired with a final result. A final result--- of 'Nothing' indicates failure. A final result of 'Just' indicates success.--- Keep in mind that forcing the second component of the returned pair will force the--- entire log.-runLog :: Log m a -> ([m], Maybe a)-runLog (Done x)       = ([], Just x)-runLog (Fail _)       = ([], Nothing)-runLog (Step m p)     = let-                          (ms, r) = runLog p-                        in-                          (m : ms, r)+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-                        (ms, s) = runLog l-                        -- 'Nothing' for 's' means search tree exhaustively searched and failed-                        (es, e) = proc 0 ms -- catch first error (always)-                        -- 'Nothing' in 'e' means no backjump found-                        (ns, t) = case mbj of-                                     Nothing -> (ms, Nothing)-                                     Just n  -> proc n ms-                        -- 'Nothing' in 't' means backjump limit not reached-                        -- prefer first error over later error-                        (exh, r) = case t of-                                     -- backjump limit not reached-                                     Nothing -> case s of-                                                  Nothing -> (True, e) -- failed after exhaustive search-                                                  Just _  -> (True, Nothing) -- success-                                     -- backjump limit reached; prefer first error-                                     Just _  -> (False, e) -- failed after backjump limit was reached+                        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 ns) -- shortened run-                            r s exh-  where-    -- Proc takes the allowed number of backjumps and a list of messages and explores the-    -- message list until the maximum number of backjumps has been reached. The log until-    -- that point as well as whether we have encountered an error or not are returned.-    proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))-    proc _ []                             = ([], Nothing)-    proc n (   Failure cs Backjump  : xs@(Leave : Failure cs' Backjump : _))-      | cs == cs'                         = proc n xs -- repeated backjumps count as one-    proc 0 (   Failure cs Backjump  : _ ) = ([], Just cs)-    proc n (x@(Failure _  Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)-    proc n (x                       : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc  n      xs)--    -- This function takes a lot of arguments. The first two 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, the fifth and six error conditions.-    -- The seventh argument indicates whether the search was exhaustive.-    ---    -- The order of arguments is important! In particular 's' must not be evaluated-    -- unless absolutely necessary. It contains the final result, and if we shortcut-    -- with an error due to backjumping, evaluating 's' would still require traversing-    -- the entire tree.-    go ms (_ : ns) (x : xs) r         s        exh = Step x (go ms ns xs r s exh)-    go ms []       (x : xs) r         s        exh = Step x (go ms [] xs r s exh)-    go ms _        []       (Just cs) _        exh = Fail $-                                                     "Could not resolve dependencies:\n" ++-                                                     unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++-                                                     (if exh then "Dependency tree exhaustively searched.\n"-                                                             else "Backjump limit reached (change with --max-backjumps).\n")-    go _  _        []       _         (Just s) _   = Done s-    go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen--logToProgress' :: Log Message a -> Progress String String a-logToProgress' l = let-                    (ms, r) = runLog l-                    xs      = showMessages (const True) True ms-                  in go xs r+                            (showMessages (const True) True ms) -- run with backjump limit applied   where-    go [x]    Nothing  = Fail x-    go []     Nothing  = Fail ""-    go []     (Just r) = Done r-    go (x:xs) r        = Step x (go xs r)+    -- 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 -runLogIO :: Log Message a -> IO (Maybe a)-runLogIO x =-  do-    let (ms, r) = runLog x-    putStr (unlines $ showMessages (const True) True ms)-    return r+    -- 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 :: m -> Log m a-failWith m = Step m (Fail ())+failWith :: step -> fail -> Progress step fail done+failWith s f = Step s (Fail f) -succeedWith :: m -> a -> Log m a-succeedWith m x = Step m (Done x)+succeedWith :: step -> done -> Progress step fail done+succeedWith s d = Step s (Done d) -continueWith :: m -> Log m a -> Log m a+continueWith :: step -> Progress step fail done -> Progress step fail done continueWith = Step -tryWith :: Message -> Log Message a -> Log Message a-tryWith m x = Step m (Step Enter x) <|> failWith Leave+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 view
@@ -1,5 +1,10 @@-module Distribution.Client.Dependency.Modular.Message where+{-# LANGUAGE BangPatterns #-} +module Distribution.Client.Dependency.Modular.Message (+    Message(..),+    showMessages+  ) where+ import qualified Data.List as L import Prelude hiding (pi) @@ -9,11 +14,14 @@ 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 (PI QPN)+  | TryP QPN POption   | TryF QFN Bool   | TryS QSN Bool   | Next (Goal QPN)@@ -32,70 +40,115 @@ -- 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 -> [Message] -> [String]+showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b showMessages p sl = go [] 0   where-    go :: [Var QPN] -> Int -> [Message] -> [String]-    go _ _ []                            = []+    -- 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 (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms-    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (add (P qpn) v) l ms)-    go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms+    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 (Enter                  : ms) = go v          (l+1) ms-    go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms-    go v l (TryP pi@(PI qpn _)     : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi) (go (add (P qpn) v) l ms)-    go v l (TryF qfn b             : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)-    go v l (TryS qsn b             : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)-    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)-    go v l (Next _                 : ms) = go v l ms -- ignore flag goals in the log-    go v l (Success                : ms) = (atLevel v l $ "done") (go v l ms)-    go v l (Failure c fr           : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms)+    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 -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]-    goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : 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: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)+    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  ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs-      | p v       = x : xs+                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs+      | p v       = Step x xs       | otherwise = xs -showGRs :: QGoalReasonChain -> String-showGRs (gr : _) = showGR gr-showGRs []       = ""+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 :: GoalReason QPN -> String+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)   = " (global constraint requires " ++ display vr ++ ")"-showFR _ GlobalConstraintInstalled      = " (global constraint requires installed instance)"-showFR _ GlobalConstraintSource         = " (global constraint requires source instance)"-showFR _ GlobalConstraintFlag           = " (global constraint requires opposite flag selection)"-showFR _ ManualFlag                     = " (manual flag can only be changed explicitly)"-showFR _ (BuildFailureNotInIndex pn)    = " (unknown package: " ++ display pn ++ ")"-showFR c Backjump                       = " (backjumping, conflict set: " ++ showCS c ++ ")"+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)"+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 view
@@ -1,5 +1,36 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.PSQ where+{-# 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. --@@ -8,14 +39,17 @@ -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice. -import Data.Foldable+import Control.Arrow (first, second)++import qualified Data.Foldable as F import Data.Function-import Data.List as S hiding (foldr)+import qualified Data.List as S+import Data.Ord (comparing) import Data.Traversable-import Prelude hiding (foldr)+import Prelude hiding (foldr, length, lookup, filter, null, map)  newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show, Functor, Foldable, Traversable)+  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@@ -24,22 +58,22 @@ lookup k (PSQ xs) = S.lookup k xs  map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2-map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)+map f (PSQ xs) = PSQ (fmap (second f) xs)  mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v-mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs)+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 (foldr (\ (k, v) r s -> case p s k v of-                                (w, n) -> (k, w) : (r n))-             (const []) 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 (partition ((== k) . fst) xs))+delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs))  fromList :: [(k, a)] -> PSQ k a fromList = PSQ@@ -57,7 +91,7 @@     (k, v) : ys -> c k v (PSQ ys)  splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits = go id +splits = go id   where     go f xs = casePSQ xs         (PSQ [])@@ -69,6 +103,62 @@ 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) @@ -78,17 +168,46 @@ length :: PSQ k a -> Int length (PSQ xs) = S.length xs --- | "Lazy length".+-- | Approximation of the branching degree. ----- Only approximates the length, but doesn't force the list.-llength :: PSQ k a -> Int-llength (PSQ [])       = 0-llength (PSQ (_:[]))   = 1-llength (PSQ (_:_:[])) = 2-llength (PSQ _)        = 3+-- 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 view
@@ -1,10 +1,28 @@ {-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Package-  (module Distribution.Client.Dependency.Modular.Package,-   module Distribution.Package) where+  ( 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 Data.Map as M  import Distribution.Package -- from Cabal import Distribution.Text    -- from Cabal@@ -25,7 +43,7 @@ type QPV = Q PV  -- | Package id. Currently just a black-box string.-type PId = InstalledPackageId+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@@ -42,11 +60,13 @@ -- | String representation of an instance. showI :: I -> String showI (I v InRepo)   = showVer v-showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i+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) ('-':)+    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 @@ -58,22 +78,79 @@ showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i --- | Checks if a package instance corresponds to an installed package.-instPI :: PI qpn -> Bool-instPI (PI _ (I _ (Inst _))) = True-instPI _                     = False- instI :: I -> Bool instI (I _ (Inst _)) = True instI _              = False --- | Package path. (Stored in "reverse" order.)-type PP = [PN]+-- | 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 = intercalate "." . L.map display . reverse-+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@@ -81,8 +158,7 @@  -- | Standard string representation of a qualified entity. showQ :: (a -> String) -> (Q a -> String)-showQ showa (Q [] x) = showa x-showQ showa (Q pp x) = showPP pp ++ "." ++ showa x+showQ showa (Q pp x) = showPP pp ++ showa x  -- | Qualified package name. type QPN = Q PN@@ -91,21 +167,9 @@ showQPN :: QPN -> String showQPN = showQ display --- | The scope associates every package with a path. The convention is that packages--- not in the data structure have an empty path associated with them.-type Scope = Map PN PP---- | An empty scope structure, for initialization.-emptyScope :: Scope-emptyScope = M.empty- -- | Create artificial parents for each of the package names, making -- them all independent.-makeIndependent :: [PN] -> Scope-makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)--qualify :: Scope -> PN -> QPN-qualify sc pn = Q (findWithDefault [] pn sc) pn--unQualify :: Q a -> a-unQualify (Q _ x) = x+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 view
@@ -1,5 +1,19 @@ {-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Preference where+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. @@ -7,45 +21,71 @@ import qualified Data.Map as M #if !MIN_VERSION_base(4,8,0) import Data.Monoid+import Control.Applicative #endif-import Data.Ord+import Prelude hiding (sequence)+import Control.Monad.Reader hiding (sequence)+import Data.Map (Map)+import Data.Traversable (sequence)  import Distribution.Client.Dependency.Types-  ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )+  ( 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 Distribution.Client.Dependency.Modular.PSQ as P+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+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 --- | Ordering that treats preferred versions as greater than non-preferred--- versions.-preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering-preferredVersionsOrdering vr v1 v2 =-  compare (checkVR vr v1) (checkVR vr v2)+    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.+-- Works by reordering choice nodes. Also applies stanza preferences. preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackagePreferences pcs = packageOrderFor (const True) preference+preferPackagePreferences pcs = preferPackageStanzaPreferences pcs+                             . packageOrderFor (const True) preference   where     preference pn i1@(I v1 _) i2@(I v2 _) =-      let PackagePreferences vr ipref = pcs pn-      in  preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically+      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@@ -67,64 +107,106 @@ 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 :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r-  | checkVR vr v  = r-  | otherwise     = Fail c (GlobalConstraintVersion vr)-processPackageConstraintP c i       (PackageConstraintInstalled _)  r-  | instI i       = r-  | otherwise     = Fail c GlobalConstraintInstalled-processPackageConstraintP c i       (PackageConstraintSource    _)  r-  | not (instI i) = r-  | otherwise     = Fail c GlobalConstraintSource-processPackageConstraintP _ _       _                               r = r+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 -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =-  case L.lookup f fa of-    Nothing            -> r-    Just b | b == b'   -> r-           | otherwise -> Fail c GlobalConstraintFlag-processPackageConstraintF _ _ _  _                             r = r+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 -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =-  if not b' && s `elem` ss then Fail c GlobalConstraintFlag-                           else r-processPackageConstraintS _ _ _  _                             r = r+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 [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain+enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]+                          -> Tree QGoalReason+                          -> Tree QGoalReason enforcePackageConstraints pcs = trav go   where-    go (PChoiceF qpn@(Q _ pn)               gr      ts) =-      let c = toConflictSet (Goal (P qpn) gr)+    go (PChoiceF qpn@(Q pp pn)              gr      ts) =+      let c = varToConflictSet (P qpn)           -- compose the transformation functions for each of the relevant constraint-          g = \ i -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id+          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 = toConflictSet (Goal (F qfn) gr)+      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 = toConflictSet (Goal (S qsn) gr)+      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)@@ -136,45 +218,29 @@ -- 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 QGoalReasonChain -> Tree QGoalReasonChain+enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason enforceManualFlags = trav go   where     go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $-      let c = toConflictSet (Goal (F qfn) gr)+      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+        isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True+        isDisabled _                                    = False     go x                                                   = x --- | Prefer installed packages over non-installed packages, generally.--- All installed packages or non-installed packages are treated as--- equivalent.-preferInstalled :: Tree a -> Tree a-preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering)---- | Prefer packages with higher version numbers over packages with--- lower version numbers, for certain packages.-preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a-preferLatestFor p = packageOrderFor p (const preferLatestOrdering)---- | Prefer packages with higher version numbers over packages with--- lower version numbers, for all packages.-preferLatest :: Tree a -> Tree a-preferLatest = preferLatestFor (const True)- -- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)+requireInstalled :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason requireInstalled p = trav go   where-    go (PChoiceF v@(Q _ pn) i@(gr, _) cs)-      | p pn      = PChoiceF v i (P.mapWithKey installed cs)-      | otherwise = PChoiceF v i                         cs+    go (PChoiceF v@(Q _ pn) gr cs)+      | p pn      = PChoiceF v gr (P.mapWithKey installed cs)+      | otherwise = PChoiceF v gr                         cs       where-        installed (I _ (Inst _)) x = x-        installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall+        installed (POption (I _ (Inst _)) _) x = x+        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall     go x          = x  -- | Avoid reinstalls.@@ -190,20 +256,21 @@ -- 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 (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)+avoidReinstalls :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason avoidReinstalls p = trav go   where-    go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)-      | p pn      = PChoiceF qpn i disableReinstalls-      | otherwise = PChoiceF qpn i cs+    go (PChoiceF qpn@(Q _ pn) gr cs)+      | p pn      = PChoiceF qpn gr disableReinstalls+      | otherwise = PChoiceF qpn gr cs       where         disableReinstalls =-          let installed = [ v | (I v (Inst _), _) <- toList cs ]+          let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ]           in  P.mapWithKey (notReinstall installed) cs -        notReinstall vs (I v InRepo) _-          | v `elem` vs                = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall-        notReinstall _  _            x = x+        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@@ -215,8 +282,7 @@ firstGoal :: Tree a -> Tree a firstGoal = trav go   where-    go (GoalChoiceF xs) = -- casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info-                          casePSQ xs (GoalChoiceF (fromList [])) (\ g t _ -> GoalChoiceF (fromList [(g, t)]))+    go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)     go x                = x     -- Note that we keep empty choice nodes, because they mean success. @@ -226,56 +292,106 @@ preferBaseGoalChoice :: Tree a -> Tree a preferBaseGoalChoice = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)     go x                = x -    preferBase :: OpenGoal -> OpenGoal -> Ordering-    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT-    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT-    preferBase _ _                                                           = EQ+    isBase :: OpenGoal comp -> Bool+    isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True+    isBase _                                                              = False --- | Transformation that sorts choice nodes so that--- child nodes with a small branching degree are preferred. As a--- special case, choices with 0 branches will be preferred (as they--- are immediately considered inconsistent), and choices with 1--- branch will also be preferred (as they don't involve choice).-preferEasyGoalChoices :: Tree a -> Tree a-preferEasyGoalChoices = trav go+-- | 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.sortBy (comparing choices) xs)+    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.sortBy defer xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))     go x                = x -    defer :: Tree a -> Tree a -> Ordering-    defer (FChoice _ _ True _ _) _ = GT-    defer _ (FChoice _ _ True _ _) = LT-    defer _ _                      = EQ+    noWeakStanza :: Tree a -> Bool+    noWeakStanza (SChoice _ _ True _) = False+    noWeakStanza _                    = True --- | Variant of 'preferEasyGoalChoices'.+    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. Less accurate,--- more efficient.-lpreferEasyGoalChoices :: Tree a -> Tree a-lpreferEasyGoalChoices = trav go+-- 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.sortBy (comparing lchoices) xs)+    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 --- | Variant of 'preferEasyGoalChoices'.+-- | 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. ----- I first thought that using a paramorphism might be faster here,--- but it doesn't seem to make any difference.-preferEasyGoalChoices' :: Tree a -> Tree a-preferEasyGoalChoices' = para (inn . go)+preferReallyEasyGoalChoices :: Tree a -> Tree a+preferReallyEasyGoalChoices = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))-    go x                = fmap fst x+    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 view
@@ -1,11 +1,19 @@-module Distribution.Client.Dependency.Modular.Solver where+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@@ -14,6 +22,7 @@ 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 {@@ -25,31 +34,62 @@   maxBackjumps          :: Maybe Int } -solve :: SolverConfig ->   -- solver parameters-         Index ->          -- all available packages as an index-         (PN -> PackagePreferences) -> -- preferences-         Map PN [PackageConstraint] -> -- global constraints-         [PN] ->                       -- global goals+-- | 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 idx userPrefs userConstraints userGoals =+solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =   explorePhase     $+  detectCyclesPhase$   heuristicsPhase  $   preferencesPhase $   validationPhase  $   prunePhase       $   buildPhase   where-    explorePhase     = exploreTreeLog . backjump-    heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)+    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 .-                       if preferEasyGoalChoices sc-                         then P.lpreferEasyGoalChoices-                         else id+                       P.preferLinked     preferencesPhase = P.preferPackagePreferences userPrefs     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints                        P.enforcePackageConstraints userConstraints .-                       validateTree idx+                       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"@@ -57,4 +97,4 @@                                                   , PackageName "integer-gmp"                                                   , PackageName "integer-simple"                                                   ])-    buildPhase       = buildTree idx (independentGoals sc) userGoals+    buildPhase       = addLinking $ buildTree idx (independentGoals sc) userGoals
Distribution/Client/Dependency/Modular/Tree.hs view
@@ -1,23 +1,39 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.Tree where+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)+import Control.Monad hiding (mapM, sequence) import Data.Foldable import Data.Traversable-import Prelude hiding (foldr, mapM)+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 as P+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 I        (Tree a))-  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual-  | SChoice     QSN a Bool      (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial-  | GoalChoice                  (PSQ OpenGoal (Tree a)) -- PSQ should never be empty+    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)@@ -30,30 +46,51 @@   -- 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-                | GlobalConstraintInstalled-                | GlobalConstraintSource-                | GlobalConstraintFlag+                | GlobalConstraintVersion VR ConstraintSource+                | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintSource ConstraintSource+                | GlobalConstraintFlag ConstraintSource                 | ManualFlag-                | BuildFailureNotInIndex PN                 | 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 I        b)-  | FChoiceF    QFN a Bool Bool (PSQ Bool     b)-  | SChoiceF    QSN a Bool      (PSQ Bool     b)-  | GoalChoiceF                 (PSQ OpenGoal 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)@@ -74,6 +111,14 @@ 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@@ -89,16 +134,24 @@ choices (Done       _         ) = 1 choices (Fail       _ _       ) = 0 --- | Variant of 'choices' that only approximates the number of choices,--- using 'llength'.-lchoices :: Tree a -> Int-lchoices (PChoice    _ _     ts) = P.llength (P.filter active ts)-lchoices (FChoice    _ _ _ _ ts) = P.llength (P.filter active ts)-lchoices (SChoice    _ _ _   ts) = P.llength (P.filter active ts)-lchoices (GoalChoice         _ ) = 1-lchoices (Done       _         ) = 1-lchoices (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@@ -110,12 +163,6 @@ para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b para phi = phi . fmap (\ x -> (para phi x, x)) . out -cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b-cataM phi = phi <=< mapM (cataM phi) <=< return . out- -- | Anamorphism on trees. ana :: (b -> TreeF a b) -> b -> Tree a ana psi = inn . fmap (ana psi) . psi--anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a)-anaM psi = return . inn <=< mapM (anaM psi) <=< psi
Distribution/Client/Dependency/Modular/Validate.hs view
@@ -1,4 +1,4 @@-module Distribution.Client.Dependency.Modular.Validate where+module Distribution.Client.Dependency.Modular.Validate (validateTree) where  -- Validation of the tree. --@@ -10,17 +10,26 @@ 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 Distribution.Client.Dependency.Modular.PSQ as P+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@@ -73,20 +82,24 @@  -- | The state needed during validation. data ValidateState = VS {+  supportedExt  :: Extension -> Bool,+  supportedLang :: Language  -> Bool,+  presentPkgs   :: PN -> VR  -> Bool,   index :: Index,-  saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies-  pa    :: PreAssignment+  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment,+  qualifyOptions :: QualifyOptions }  type Validate = Reader ValidateState -validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain)+validate :: Tree QGoalReason -> Validate (Tree QGoalReason) validate = cata go   where-    go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)+    go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason) -    go (PChoiceF qpn (gr,  sc)     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)-    go (FChoiceF qfn (gr, _sc) b m ts) =+    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@@ -95,21 +108,21 @@         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 gr rb t-                       Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)+                       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 gr) ts)-    go (SChoiceF qsn (gr, _sc) b   ts) =+                     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 gr rb t-                       Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)+                       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 gr) ts)+                     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@@ -117,24 +130,29 @@     go (FailF    c fr              ) = pure (Fail c fr)      -- What to do for package nodes ...-    goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goP qpn@(Q _pp pn) gr sc i r = do+    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-      let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice-      let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope+      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 goal = Goal (P qpn) gr-      let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)+      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 (P qpn) ppa newactives+      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 (toConflictSet goal) fr)+                   return (Fail (varToConflictSet (P qpn)) fr)         _       -> case mnppa of                      Left (c, d) -> -- We have an inconsistency. We can stop.                                     return (Fail c (Conflicting d))@@ -142,9 +160,12 @@                                     local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r      -- What to do for flag nodes ...-    goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goF qfn@(FN (PI qpn _i) _f) gr b r = do+    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@@ -157,16 +178,19 @@       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) gr b npfa psa qdeps+      let newactives = extractNewDeps (F qfn) b npfa psa qdeps       -- As in the package case, we try to extend the partial assignment.-      case extend (F qfn) ppa newactives of+      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 -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goS qsn@(SN (PI qpn _i) _f) gr b r = do+    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@@ -179,20 +203,20 @@       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) gr b pfa npsa qdeps+      let newactives = extractNewDeps (S qsn) b pfa npsa qdeps       -- As in the package case, we try to extend the partial assignment.-      case extend (S qsn) ppa newactives of+      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 QPN -> [Dep QPN]+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] extractDeps fa sa deps = do   d <- deps   case d of-    Simple sd           -> return sd+    Simple sd _         -> return sd     Flagged qfn _ td fd -> case M.lookup qfn fa of                              Nothing    -> mzero                              Just True  -> extractDeps fa sa td@@ -205,22 +229,23 @@ -- | 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 -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]-extractNewDeps v gr b fa sa = go+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+        Simple _ _           -> mzero         Flagged qfn' _ td fd-          | v == F qfn'      -> L.map (resetGoal (Goal v gr)) $+          | 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 (resetGoal (Goal v gr)) $+          | v == S qsn'      -> L.map (resetVar v) $                                 if b then extractDeps fa sa td else []           | otherwise        -> case M.lookup qsn' sa of                                   Nothing    -> mzero@@ -228,5 +253,17 @@                                   Just False -> []  -- | Interface.-validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain-validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))+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 view
@@ -0,0 +1,45 @@+{-# 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 view
@@ -1,4 +1,15 @@-module Distribution.Client.Dependency.Modular.Version where+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@@ -29,6 +40,10 @@ (.&&.) :: 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@@ -36,7 +51,3 @@ -- | Checking a version against a version range. checkVR :: VR -> Ver -> Bool checkVR = flip CV.withinRange---- | Make a version number.-mkV :: [Int] -> Ver-mkV xs = CV.Version xs []
Distribution/Client/Dependency/TopDown.hs view
@@ -19,25 +19,29 @@ import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints import Distribution.Client.Dependency.TopDown.Constraints          ( Satisfiable(..) )-import Distribution.Client.IndexUtils-         ( convert )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan-         ( PlanPackage(..) ) import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)-         , enableStanzas )+         ( SourcePackage(..), ConfiguredPackage(..)+         , enableStanzas, ConfiguredId(..), fakeUnitId ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..)+         ( DependencyResolver, ResolverPackage(..)+         , PackageConstraint(..), unlabelPackageConstraint          , PackagePreferences(..), InstalledPreference(..)          , Progress(..), foldProgress )  import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (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, Package(..), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion-         , simplifyDependency, PackageFixedDeps(depends) )+         ( PackageName(..), PackageId, PackageIdentifier(..)+         , UnitId(..), ComponentId(..)+         , Package(..), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion, simplifyDependency ) import Distribution.PackageDescription          ( PackageDescription(buildDepends) ) import Distribution.Client.PackageUtils@@ -45,7 +49,7 @@ import Distribution.PackageDescription.Configuration          ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version-         ( VersionRange, withinRange, simplifyVersionRange+         ( Version(..), VersionRange, withinRange, simplifyVersionRange          , UpperBound(..), asVersionIntervals ) import Distribution.Compiler          ( CompilerInfo )@@ -123,8 +127,10 @@       where         isInstalled (SourceOnly _) = False         isInstalled _              = True-        isPreferred p = packageVersion p `withinRange` preferredVersions-        (PackagePreferences preferredVersions packageInstalledPreference)+        isPreferred p = length . filter (packageVersion p `withinRange`) $+                        preferredVersions++        (PackagePreferences preferredVersions packageInstalledPreference _)           = pref pkgname      logInfo node = Select selected discarded@@ -245,11 +251,15 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver-topDownResolver platform cinfo installedPkgIndex sourcePkgIndex+topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB                 preferences constraints targets =-    mapMessages (topDownResolver' platform cinfo-                                  (convert installedPkgIndex) sourcePkgIndex-                                  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@@ -262,7 +272,7 @@                  -> (PackageName -> PackagePreferences)                  -> [PackageConstraint]                  -> [PackageName]-                 -> Progress Log Failure [PlanPackage]+                 -> Progress Log Failure [ResolverPackage] topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex                  preferences constraints targets =       fmap (uncurry finalise)@@ -284,11 +294,16 @@     initialPkgNames = Set.fromList targets      finalise selected' constraints' =-        PackageIndex.allPackages+        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@@ -423,7 +438,7 @@     transitiveDepends :: InstalledPackage -> [PackageId]     transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph                       . fromJust . toVertex . packageId-    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed+    (graph, toPkg, toVertex) = dependencyGraph installed   -- | Annotate each available packages with its topological sort number and any@@ -481,7 +496,7 @@          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex          , let deps = [ packageName dep                       | pkg' <- pkgs-                      , dep  <- depends pkg' ] ]+                      , dep  <- sourceDeps pkg' ] ]       ++ [ ((), packageName pkg, nub deps)          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex          , let deps = [ depName@@ -519,7 +534,7 @@                         filter notAlreadyIncluded                       $ [ packageName dep                         | pkg <- moreInstalled-                        , dep <- depends pkg ]+                        , dep <- sourceDeps pkg ]                      ++ [ name                         | SourcePackage _ pkg _ _ <- moreSource                         , Dependency name _ <-@@ -534,6 +549,43 @@             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 -- ------------------------------------------------------------@@ -541,7 +593,7 @@ finaliseSelectedPackages :: (PackageName -> PackagePreferences)                          -> SelectedPackages                          -> Constraints-                         -> [PlanPackage]+                         -> [FinalSelectedPackage] finaliseSelectedPackages pref selected constraints =   map finaliseSelected (PackageIndex.allPackages selected)   where@@ -557,12 +609,46 @@         Just (InstalledOnly _)        -> finaliseInstalled ipkg         Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg -    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg+    finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg     finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =-      InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')+        SelectedSource (ConfiguredPackage pkg flags stanzas deps')       where-        deps' = map (packageId . pickRemaining mipkg) deps+        -- 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"@@ -579,15 +665,17 @@         -- silly things like deciding to rebuild haskell98 against base 3.         isCurrent = case mipkg :: Maybe InstalledPackageEx of           Nothing   -> \_ -> False-          Just ipkg -> \p -> packageId p `elem` depends ipkg+          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   = True -- any constant will do-          | otherwise = packageVersion p `withinRange` preferredVersions-          where (PackagePreferences preferredVersions _) = pref (packageName 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@@ -611,8 +699,8 @@ -- improvePlan :: PackageIndex InstalledPackage             -> Constraints-            -> PackageIndex PlanPackage-            -> (PackageIndex PlanPackage, Constraints)+            -> PackageIndex FinalSelectedPackage+            -> (PackageIndex FinalSelectedPackage, Constraints) improvePlan installed constraints0 selected0 =   foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)   where@@ -625,27 +713,27 @@     -- 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-      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid-      ipkg            <- PackageIndex.lookupPackageId installed pkgid-      guard $ all (isInstalled selected) (depends pkg)+      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 (PreExisting _) -> True-        _                    -> False+        Just (SelectedInstalled _) -> True+        _                          -> False -    tryInstalled :: PackageIndex PlanPackage -> Constraints+    tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints                  -> [InstalledPackage]-                 -> Maybe (PackageIndex PlanPackage, Constraints)+                 -> Maybe (PackageIndex FinalSelectedPackage, Constraints)     tryInstalled selected constraints [] = Just (selected, constraints)     tryInstalled selected constraints (pkg:pkgs) =-      case constraintsOk (packageId pkg) (depends pkg) constraints of+      case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of         Nothing           -> Nothing         Just constraints' -> tryInstalled selected' constraints' pkgs'           where-            selected' = PackageIndex.insert (PreExisting pkg) selected-            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs+            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@@ -660,13 +748,12 @@       where         dep = thisPackageVersion pkgid' -    reverseTopologicalOrder :: PackageFixedDeps pkg-                            => PackageIndex pkg -> [PackageId]+    reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId]     reverseTopologicalOrder index = map (packageId . toPkg)                                   . Graph.topSort                                   . Graph.transposeG                                   $ graph-      where (graph, toPkg, _) = PackageIndex.dependencyGraph index+      where (graph, toPkg, _) = dependencyGraph index  -- ------------------------------------------------------------ -- * Adding and recording constraints@@ -944,3 +1031,49 @@ 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 view
@@ -26,11 +26,12 @@  import Distribution.Client.Dependency.TopDown.Types import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.PackageIndex+        ( PackageIndex ) import Distribution.Package          ( PackageName, PackageId, PackageIdentifier(..)          , Package(packageId), packageName, packageVersion-         , Dependency, PackageFixedDeps(depends) )+         , Dependency ) import Distribution.Version          ( Version ) import Distribution.Client.Utils@@ -224,14 +225,12 @@       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 :: (PackageFixedDeps installed, Package source)-      => PackageIndex installed-      -> PackageIndex source-      -> Constraints installed source reason+empty :: PackageIndex InstalledPackageEx+      -> PackageIndex UnconfiguredPackage+      -> Constraints InstalledPackageEx UnconfiguredPackage reason empty installed source =     Constraints targets pkgs excluded pairs pkgs   where@@ -253,27 +252,24 @@       , let name   = packageName pkg1             pkgid1 = packageId pkg1             pkgid2 = packageId pkg2-      ,    any ((pkgid1==) . packageId) (depends pkg2)-        || any ((pkgid2==) . packageId) (depends pkg1) ]+      ,    any ((pkgid1==) . packageId) (sourceDeps pkg2)+        || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]   -- | The package targets. ---packages :: (Package installed, Package source)-         => Constraints installed source reason+packages :: Constraints installed source reason          -> Set PackageName packages (Constraints ts _ _ _ _) = ts   -- | The package choices that are still available. ---choices :: (Package installed, Package source)-        => Constraints installed source reason+choices :: Constraints installed source reason         -> PackageIndex (InstalledOrSource installed source) choices (Constraints _ available _ _ _) = available -isPaired :: (Package installed, Package source)-         => Constraints installed source reason+isPaired :: Constraints installed source reason          -> PackageId -> Maybe PackageId isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =   case Map.lookup name pairs of
Distribution/Client/Dependency/TopDown/Types.hs view
@@ -10,14 +10,19 @@ -- -- Types for the top-down dependency resolver. -----------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Distribution.Client.Dependency.TopDown.Types where  import Distribution.Client.Types-         ( SourcePackage(..), InstalledPackage, OptionalStanza )+         ( SourcePackage(..), ConfiguredPackage(..)+         , OptionalStanza, ConfiguredId(..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.Client.ComponentDeps as CD  import Distribution.Package-         ( PackageIdentifier, Dependency-         , Package(packageId), PackageFixedDeps(depends) )+         ( PackageId, PackageIdentifier, Dependency+         , Package(packageId) ) import Distribution.PackageDescription          ( FlagAssignment ) @@ -37,8 +42,18 @@    | 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@@ -60,12 +75,12 @@        [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 PackageFixedDeps InstalledPackageEx where-  depends (InstalledPackageEx _ _ deps) = deps- instance Package UnconfiguredPackage where   packageId (UnconfiguredPackage p _ _ _) = packageId p @@ -78,7 +93,11 @@   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. --@@ -89,3 +108,36 @@ 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,5 +1,6 @@-{-# LANGUAGE CPP           #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency.Types@@ -13,21 +14,25 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types (-    ExtDependency(..),-     PreSolver(..),     Solver(..),     DependencyResolver,+    ResolverPackage(..), -    AllowNewer(..), isAllowNewer,     PackageConstraint(..),-    debugPackageConstraint,+    showPackageConstraint,     PackagePreferences(..),     InstalledPreference(..),     PackagesPreferenceDefault(..),      Progress(..),     foldProgress,++    LabeledPackageConstraint(..),+    ConstraintSource(..),+    unlabelPackageConstraint,+    showConstraintSource+   ) where  #if !MIN_VERSION_base(4,8,0)@@ -37,7 +42,6 @@ import Control.Applicative          ( Alternative(..) ) - import Data.Char          ( isAlpha, toLower ) #if !MIN_VERSION_base(4,8,0)@@ -45,22 +49,22 @@          ( Monoid(..) ) #endif +import Distribution.Client.PkgConfigDb+         ( PkgConfigDb ) import Distribution.Client.Types-         ( OptionalStanza(..), SourcePackage(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan--import Distribution.Compat.ReadP-         ( (<++) )+         ( 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-         ( Dependency, PackageName, InstalledPackageId )+         ( PackageName ) import Distribution.Version          ( VersionRange, simplifyVersionRange ) import Distribution.Compiler@@ -72,28 +76,23 @@  import Text.PrettyPrint          ( text )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))  import Prelude hiding (fail) --- | Covers source dependencies and installed dependencies in--- one type.-data ExtDependency = SourceDependency Dependency-                   | InstalledDependency InstalledPackageId -instance Text ExtDependency where-  disp (SourceDependency    dep) = disp dep-  disp (InstalledDependency dep) = disp dep--  parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)- -- | All the solvers that can be selected. data PreSolver = AlwaysTopDown | AlwaysModular | Choose-  deriving (Eq, Ord, Show, Bounded, Enum)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  -- | All the solvers that can be used. data Solver = TopDown | Modular-  deriving (Eq, Ord, Show, Bounded, Enum)+  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"@@ -118,11 +117,20 @@                        -> CompilerInfo                        -> InstalledPackageIndex                        ->          PackageIndex.PackageIndex SourcePackage+                       -> PkgConfigDb                        -> (PackageName -> PackagePreferences)-                       -> [PackageConstraint]+                       -> [LabeledPackageConstraint]                        -> [PackageName]-                       -> Progress String String [InstallPlan.PlanPackage]+                       -> 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@@ -134,40 +142,45 @@    | PackageConstraintSource    PackageName    | PackageConstraintFlags     PackageName FlagAssignment    | PackageConstraintStanzas   PackageName [OptionalStanza]-  deriving (Show,Eq)+  deriving (Eq,Show,Generic) +instance Binary PackageConstraint+ -- | Provide a textual representation of a package constraint -- for debugging purposes. ---debugPackageConstraint :: PackageConstraint -> String-debugPackageConstraint (PackageConstraintVersion pn vr) =+showPackageConstraint :: PackageConstraint -> String+showPackageConstraint (PackageConstraintVersion pn vr) =   display pn ++ " " ++ display (simplifyVersionRange vr)-debugPackageConstraint (PackageConstraintInstalled pn) =+showPackageConstraint (PackageConstraintInstalled pn) =   display pn ++ " installed"-debugPackageConstraint (PackageConstraintSource pn) =+showPackageConstraint (PackageConstraintSource pn) =   display pn ++ " source"-debugPackageConstraint (PackageConstraintFlags pn fs) =+showPackageConstraint (PackageConstraintFlags pn fs) =   "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs)   where     showFlag (FlagName f) True  = "+" ++ f     showFlag (FlagName f) False = "-" ++ f-debugPackageConstraint (PackageConstraintStanzas pn ss) =+showPackageConstraint (PackageConstraintStanzas pn ss) =   "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss)   where     showStanza TestStanzas  = "test"     showStanza BenchStanzas = "bench" --- | A per-package preference on the version. It is a soft constraint that the+-- | Per-package preferences on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of--- a 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also has a 'PackageVersionPreference' which--- is a suggested constraint on the version number. The resolver should try to--- use package versions that satisfy the suggested version constraint.+-- 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+data PackagePreferences = PackagePreferences [VersionRange]+                                             InstalledPreference+                                             [OptionalStanza]  -- | Whether we prefer an installed version of a package or simply the latest -- version.@@ -200,28 +213,6 @@    | PreferLatestForSelected   deriving Show --- | Policy for relaxing upper bounds in dependencies. For example, given--- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper--- bound and choose a version of 'array' that is greater or equal to 0.5? By--- default the upper bounds are always strictly honored.-data AllowNewer =--  -- | Default: honor the upper bounds in all dependencies, never choose-  -- versions newer than allowed.-  AllowNewerNone--  -- | Ignore upper bounds in dependencies on the given packages.-  | AllowNewerSome [PackageName]--  -- | Ignore upper bounds in dependencies on all packages.-  | AllowNewerAll---- | Convert 'AllowNewer' to a boolean.-isAllowNewer :: AllowNewer -> Bool-isAllowNewer AllowNewerNone     = False-isAllowNewer (AllowNewerSome _) = True-isAllowNewer AllowNewerAll      = True- -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- result which may be used to indicate progress and\/or logging messages.@@ -229,7 +220,7 @@ data Progress step fail done = Step step (Progress step fail done)                              | Fail fail                              | Done done-  deriving Functor+  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.@@ -246,7 +237,7 @@         fold (Done r)   = done r  instance Monad (Progress step fail) where-  return a = Done a+  return   = pure   p >>= f  = foldProgress Step Fail f p  instance Applicative (Progress step fail) where@@ -256,3 +247,72 @@ 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
@@ -0,0 +1,134 @@+{-# LANGUAGE RecordWildCards #-}++-- | +--+-- The layout of the .\/dist\/ directory where cabal keeps all of it's state+-- and build artifacts.+--+module Distribution.Client.DistDirLayout where++import System.FilePath+import Distribution.Package+         ( PackageId )+import Distribution.Compiler+import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Text+import Distribution.Client.Types+         ( InstalledPackageId )++++-- | 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.+       --+       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+       -- we can have multiple instances of the same package in a solution+       -- (e.g. setup deps).+       --+       distBuildDirectory           :: PackageId -> FilePath,+       distBuildRootDirectory       :: FilePath,++       -- | The directory under dist where we put the unpacked sources of+       -- packages, in those cases where it makes sense to keep the build+       -- artifacts to reduce rebuild times. These can be tarballs or could be+       -- scm repos.+       --+       distUnpackedSrcDirectory     :: PackageId -> FilePath,+       distUnpackedSrcRootDirectory :: FilePath,++       -- | The location for project-wide cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distProjectCacheFile         :: String -> FilePath,+       distProjectCacheDirectory    :: FilePath,++       -- | The location for package-specific cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distPackageCacheFile         :: PackageId -> String -> FilePath,+       distPackageCacheDirectory    :: PackageId -> FilePath,++       distTempDirectory            :: FilePath,+       distBinDirectory             :: FilePath,++       distPackageDB                :: CompilerId -> PackageDB+     }++++--TODO: move to another module, e.g. CabalDirLayout?+data CabalDirLayout = CabalDirLayout {+       cabalStoreDirectory        :: CompilerId -> FilePath,+       cabalStorePackageDirectory :: CompilerId -> InstalledPackageId+                                                -> FilePath,+       cabalStorePackageDBPath    :: CompilerId -> FilePath,+       cabalStorePackageDB        :: CompilerId -> PackageDB,++       cabalPackageCacheDirectory :: FilePath,+       cabalLogsDirectory         :: FilePath,+       cabalWorldFile             :: FilePath+     }+++defaultDistDirLayout :: FilePath -> DistDirLayout+defaultDistDirLayout projectRootDirectory =+    DistDirLayout {..}+  where+    distDirectory = projectRootDirectory </> "dist-newstyle"+    --TODO: switch to just dist at some point, or some other new name++    distBuildRootDirectory   = distDirectory </> "build"+    distBuildDirectory pkgid = distBuildRootDirectory </> display pkgid++    distUnpackedSrcRootDirectory   = distDirectory </> "src"+    distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory+                                      </> display pkgid++    distProjectCacheDirectory = distDirectory </> "cache"+    distProjectCacheFile name = distProjectCacheDirectory </> name++    distPackageCacheDirectory pkgid = distBuildDirectory pkgid </> "cache"+    distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid </> name++    distTempDirectory = distDirectory </> "tmp"++    distBinDirectory = distDirectory </> "bin"++    distPackageDBPath compid = distDirectory </> "packagedb" </> display compid+    distPackageDB = SpecificPackageDB . distPackageDBPath++++defaultCabalDirLayout :: FilePath -> CabalDirLayout+defaultCabalDirLayout cabalDir =+    CabalDirLayout {..}+  where++    cabalStoreDirectory compid =+      cabalDir </> "store" </> display compid++    cabalStorePackageDirectory compid ipkgid = +      cabalStoreDirectory compid </> display ipkgid++    cabalStorePackageDBPath compid =+      cabalStoreDirectory compid </> "package.db"++    cabalStorePackageDB =+      SpecificPackageDB . cabalStorePackageDBPath++    cabalPackageCacheDirectory = cabalDir </> "packages"++    cabalLogsDirectory = cabalDir </> "logs"++    cabalWorldFile = cabalDir </> "world"+
Distribution/Client/Exec.hs view
@@ -12,6 +12,8 @@ module Distribution.Client.Exec ( exec                                 ) where +import Control.Monad (unless)+ import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS @@ -25,11 +27,12 @@ import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )-import Distribution.Simple.Utils       (die)+import Distribution.Simple.Utils       (die, warn)  import Distribution.System    (Platform) import Distribution.Verbosity (Verbosity) +import System.Directory ( doesDirectoryExist ) import System.FilePath (searchPathSeparator, (</>)) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))@@ -60,7 +63,7 @@          [] -> die "Please specify an executable to run"   where-    environmentOverrides = +    environmentOverrides =         case useSandbox of             NoSandbox -> return []             (UseSandbox sandboxDir) ->@@ -86,15 +89,18 @@         let Just program = lookupProgram hcProgram programDb         gDb <- getGlobalPackageDB verbosity program         sandboxConfigFilePath <- getSandboxConfigFilePath mempty-        let compilerPackagePath = hcPackagePath gDb-        return [ (packagePathEnvVar, compilerPackagePath)-               , ("CABAL_SANDBOX_PACKAGE_PATH", compilerPackagePath)+        let sandboxPackagePath   = sandboxPackageDBPath sandboxDir comp platform+            compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath+        -- Packages database must exist, otherwise things will start+        -- failing in mysterious ways.+        exists <- doesDirectoryExist sandboxPackagePath+        unless exists $ warn verbosity $ "Package database is not a directory: "+                                           ++ sandboxPackagePath+        -- Build the environment+        return [ (packagePathEnvVar, Just compilerPackagePaths)+               , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)                , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)                ]--    hcPackagePath gDb =-        let s = sandboxPackageDBPath sandboxDir comp platform-            in Just $ prependToSearchPath gDb s      prependToSearchPath path newValue =         newValue ++ [searchPathSeparator] ++ path
Distribution/Client/Fetch.hs view
@@ -22,8 +22,10 @@ import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup-         ( GlobalFlags(..), FetchFlags(..) )+         ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )  import Distribution.Package          ( packageId )@@ -64,7 +66,7 @@ -- fetch :: Verbosity       -> PackageDBStack-      -> [Repo]+      -> RepoContext       -> Compiler       -> Platform       -> ProgramConfiguration@@ -75,22 +77,23 @@ fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repos comp platform conf+fetch verbosity packageDBs repoCtxt comp platform conf       globalFlags fetchFlags userTargets = do      mapM_ checkTarget userTargets      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf -    pkgSpecifiers <- resolveUserTargets verbosity+    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        userTargets      pkgs  <- planPackages                verbosity comp platform fetchFlags-               installedPkgIndex sourcePkgDb pkgSpecifiers+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers      pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs     if null pkgs'@@ -105,7 +108,7 @@                      "The following packages would be fetched:"                    : map (display . packageId) pkgs' -             else mapM_ (fetchPackage verbosity . packageSource) pkgs'+             else mapM_ (fetchPackage verbosity repoCtxt . packageSource) pkgs'    where     dryRun = fromFlag (fetchDryRun fetchFlags)@@ -116,10 +119,11 @@              -> FetchFlags              -> InstalledPackageIndex              -> SourcePackageDb+             -> PkgConfigDb              -> [PackageSpecifier SourcePackage]              -> IO [SourcePackage] planPackages verbosity comp platform fetchFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers    | includeDependencies = do       solver <- chooseSolver verbosity@@ -127,7 +131,7 @@       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies-                         platform (compilerInfo comp)+                         platform (compilerInfo comp) pkgConfigDb                          solver                          resolverParams @@ -135,7 +139,7 @@       -- that are in the 'InstallPlan.Configured' state.       return         [ pkg-        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))+        | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _))             <- InstallPlan.toList installPlan ]    | otherwise =@@ -181,8 +185,8 @@             ++ "In the meantime you can use the 'unpack' commands."     _ -> return () -fetchPackage :: Verbosity -> PackageLocation a -> IO ()-fetchPackage verbosity pkgsrc = case pkgsrc of+fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()+fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of     LocalUnpackedPackage _dir  -> return ()     LocalTarballPackage  _file -> return () @@ -191,5 +195,5 @@          ++ "In the meantime you can use the 'unpack' commands."      RepoTarballPackage repo pkgid _ -> do-      _ <- fetchRepoTarball verbosity repo pkgid+      _ <- fetchRepoTarball verbosity repoCtxt repo pkgid       return ()
Distribution/Client/FetchUtils.hs view
@@ -11,6 +11,7 @@ -- -- Functions for fetching packages -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} module Distribution.Client.FetchUtils (      -- * fetching packages@@ -19,6 +20,7 @@     checkFetched,      -- ** specifically for repo packages+    checkRepoTarballFetched,     fetchRepoTarball,      -- * fetching other things@@ -27,7 +29,8 @@  import Distribution.Client.Types import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI, DownloadResult(..) )+         ( downloadURI, isOldHackageURI, DownloadResult(..)+         , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )  import Distribution.Package          ( PackageId, packageName, packageVersion )@@ -37,6 +40,8 @@          ( display ) import Distribution.Verbosity          ( Verbosity )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )  import Data.Maybe import System.Directory@@ -50,6 +55,8 @@ import Network.URI          ( URI(uriPath) ) +import qualified Hackage.Security.Client as Sec+ -- ------------------------------------------------------------ -- * Actually fetch things -- ------------------------------------------------------------@@ -65,6 +72,10 @@     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 loc = case loc of@@ -78,20 +89,29 @@       return (Just $ RepoTarballPackage repo pkgid file)      RemoteTarballPackage _uri Nothing -> return Nothing-    RepoTarballPackage repo pkgid Nothing -> do-      let file = packageFile repo pkgid-      exists <- doesFileExist file-      if exists-        then return (Just $ RepoTarballPackage repo pkgid file)-        else return Nothing+    RepoTarballPackage repo pkgid Nothing ->+      fmap (fmap (RepoTarballPackage repo pkgid))+           (checkRepoTarballFetched repo pkgid)  +-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.+--+checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)+checkRepoTarballFetched repo pkgid = do+    let file = packageFile repo pkgid+    exists <- doesFileExist file+    if exists+      then return (Just file)+      else return Nothing++ -- | Fetch a package if we don't have it already. -- fetchPackage :: Verbosity+             -> RepoContext              -> PackageLocation (Maybe FilePath)              -> IO (PackageLocation FilePath)-fetchPackage verbosity loc = case loc of+fetchPackage verbosity repoCtxt loc = case loc of     LocalUnpackedPackage dir  ->       return (LocalUnpackedPackage dir)     LocalTarballPackage  file ->@@ -105,22 +125,24 @@       path <- downloadTarballPackage uri       return (RemoteTarballPackage uri path)     RepoTarballPackage repo pkgid Nothing -> do-      local <- fetchRepoTarball verbosity repo pkgid+      local <- fetchRepoTarball verbosity repoCtxt repo pkgid       return (RepoTarballPackage repo pkgid local)   where     downloadTarballPackage uri = do+      transport <- repoContextGetTransport repoCtxt+      transportCheckHttps transport uri       notice verbosity ("Downloading " ++ show uri)       tmpdir <- getTemporaryDirectory       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"       hClose hnd-      _ <- downloadURI verbosity uri path+      _ <- downloadURI transport verbosity uri path       return path   -- | Fetch a repo package if we don't have it already. ---fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath-fetchRepoTarball verbosity repo pkgid = do+fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity repoCtxt repo pkgid = do   fetched <- doesFileExist (packageFile repo pkgid)   if fetched     then do info verbosity $ display pkgid ++ " has already been downloaded."@@ -128,28 +150,40 @@     else do setupMessage verbosity "Downloading" pkgid             downloadRepoPackage   where-    downloadRepoPackage = case repoKind repo of-      Right LocalRepo -> return (packageFile repo pkgid)+    downloadRepoPackage = case repo of+      RepoLocal{..} -> return (packageFile repo pkgid) -      Left remoteRepo -> do-        let uri  = packageURI remoteRepo pkgid-            dir  = packageDir       repo pkgid-            path = packageFile      repo pkgid+      RepoRemote{..} -> do+        transport <- repoContextGetTransport repoCtxt+        remoteRepoCheckHttps transport repoRemote+        let uri  = packageURI  repoRemote pkgid+            dir  = packageDir  repo       pkgid+            path = packageFile repo       pkgid         createDirectoryIfMissing True dir-        _ <- downloadURI verbosity uri path+        _ <- downloadURI transport verbosity uri path         return path +      RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do+        let dir  = packageDir  repo pkgid+            path = packageFile repo pkgid+        createDirectoryIfMissing True dir+        Sec.uncheckClientErrors $ do+          info verbosity ("writing " ++ path)+          Sec.downloadPackage' rep pkgid path+        return path+ -- | Downloads an index file to [config-dir/packages/serv-id]. ---downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult-downloadIndex verbosity repo cacheDir = do-  let uri = (remoteRepoURI repo) {-              uriPath = uriPath (remoteRepoURI repo)+downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult+downloadIndex transport verbosity remoteRepo cacheDir = do+  remoteRepoCheckHttps transport remoteRepo+  let uri = (remoteRepoURI remoteRepo) {+              uriPath = uriPath (remoteRepoURI remoteRepo)                           `FilePath.Posix.combine` "00-index.tar.gz"             }       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir-  downloadURI verbosity uri path+  downloadURI transport verbosity uri path   -- ------------------------------------------------------------
+ Distribution/Client/FileMonitor.hs view
@@ -0,0 +1,1119 @@+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,+             NamedFieldPuns, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | An abstraction to help with re-running actions when files or other+-- input values they depend on have changed.+--+module Distribution.Client.FileMonitor (++  -- * Declaring files to monitor+  MonitorFilePath(..),+  MonitorKindFile(..),+  MonitorKindDir(..),+  FilePathGlob(..),+  monitorFile,+  monitorFileHashed,+  monitorNonExistentFile,+  monitorDirectory,+  monitorNonExistentDirectory,+  monitorDirectoryExistence,+  monitorFileOrDirectory,+  monitorFileGlob,+  monitorFileGlobExistence,+  monitorFileSearchPath,+  monitorFileHashedSearchPath,++  -- * Creating and checking sets of monitored files+  FileMonitor(..),+  newFileMonitor,+  MonitorChanged(..),+  MonitorChangedReason(..),+  checkFileMonitorChanged,+  updateFileMonitor,+  MonitorTimestamp,+  beginUpdateFileMonitor,+  ) where+++#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)+import qualified Control.Monad.State as State+import           Control.Monad.Except (ExceptT, runExceptT, withExceptT,+                                       throwError)+import           Control.Exception++import           Distribution.Client.Compat.Time+import           Distribution.Client.Glob+import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)+import           Distribution.Client.Utils (mergeBy, MergeResult(..))++import           System.FilePath+import           System.Directory+import           System.IO+import           GHC.Generics (Generic)+++------------------------------------------------------------------------------+-- Types for specifying files to monitor+--+++-- | A description of a file (or set of files) to monitor for changes.+--+-- Where file paths are relative they are relative to a common directory+-- (e.g. project root), not necessarily the process current directory.+--+data MonitorFilePath =+     MonitorFile {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPath     :: !FilePath+     }+   | MonitorFileGlob {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPathGlob :: !FilePathGlob+     }+  deriving (Eq, Show, Generic)++data MonitorKindFile = FileExists+                     | FileModTime+                     | FileHashed+                     | FileNotExists+  deriving (Eq, Show, Generic)++data MonitorKindDir  = DirExists+                     | DirModTime+                     | DirNotExists+  deriving (Eq, Show, Generic)++instance Binary MonitorFilePath+instance Binary MonitorKindFile+instance Binary MonitorKindDir++-- | Monitor a single file for changes, based on its modification time.+-- The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFile :: FilePath -> MonitorFilePath+monitorFile = MonitorFile FileModTime DirNotExists++-- | Monitor a single file for changes, based on its modification time+-- and content hash. The monitored file is considered to have changed if+-- it no longer exists or if its modification time and content hash have+-- changed.+--+monitorFileHashed :: FilePath -> MonitorFilePath+monitorFileHashed = MonitorFile FileHashed DirNotExists++-- | Monitor a single non-existent file for changes. The monitored file+-- is considered to have changed if it exists.+--+monitorNonExistentFile :: FilePath -> MonitorFilePath+monitorNonExistentFile = MonitorFile FileNotExists DirNotExists++-- | Monitor a single directory for changes, based on its modification+-- time. The monitored directory is considered to have changed if it no+-- longer exists or if its modification time has changed.+--+monitorDirectory :: FilePath -> MonitorFilePath+monitorDirectory = MonitorFile FileNotExists DirModTime++-- | Monitor a single non-existent directory for changes.  The monitored+-- directory is considered to have changed if it exists.+--+monitorNonExistentDirectory :: FilePath -> MonitorFilePath+-- Just an alias for monitorNonExistentFile, since you can't+-- tell the difference between a non-existent directory and+-- a non-existent file :)+monitorNonExistentDirectory = monitorNonExistentFile++-- | Monitor a single directory for existence. The monitored directory is+-- considered to have changed only if it no longer exists.+--+monitorDirectoryExistence :: FilePath -> MonitorFilePath+monitorDirectoryExistence = MonitorFile FileNotExists DirExists++-- | Monitor a single file or directory for changes, based on its modification+-- time. The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFileOrDirectory :: FilePath -> MonitorFilePath+monitorFileOrDirectory = MonitorFile FileModTime DirModTime++-- | Monitor a set of files (or directories) identified by a file glob.+-- The monitored glob is considered to have changed if the set of files+-- matching the glob changes (i.e. creations or deletions), or for files if the+-- modification time and content hash of any matching file has changed.+--+monitorFileGlob :: FilePathGlob -> MonitorFilePath+monitorFileGlob = MonitorFileGlob FileHashed DirExists++-- | Monitor a set of files (or directories) identified by a file glob for+-- existence only. The monitored glob is considered to have changed if the set+-- of files matching the glob changes (i.e. creations or deletions).+--+monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists++-- | Creates a list of files to monitor when you search for a file which+-- unsuccessfully looked in @notFoundAtPaths@ before finding it at+-- @foundAtPath@.+monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileSearchPath notFoundAtPaths foundAtPath =+    monitorFile foundAtPath+  : map monitorNonExistentFile notFoundAtPaths++-- | Similar to 'monitorFileSearchPath', but also instructs us to+-- monitor the hash of the found file.+monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileHashedSearchPath notFoundAtPaths foundAtPath =+    monitorFileHashed foundAtPath+  : map monitorNonExistentFile notFoundAtPaths+++------------------------------------------------------------------------------+-- Implementation types, files status+--++-- | The state necessary to determine whether a set of monitored+-- files has changed.  It consists of two parts: a set of specific+-- files to be monitored (index by their path), and a list of+-- globs, which monitor may files at once.+data MonitorStateFileSet+   = MonitorStateFileSet !(Map FilePath MonitorStateFile)+                         ![MonitorStateGlob]+  deriving Show++type Hash = Int++-- | The state necessary to determine whether a monitored file has changed.+--+-- This covers all the cases of 'MonitorFilePath' except for globs which is+-- covered separately by 'MonitorStateGlob'.+--+-- The @Maybe ModTime@ is to cover the case where we already consider the+-- file to have changed, either because it had already changed by the time we+-- did the snapshot (i.e. too new, changed since start of update process) or it+-- no longer exists at all.+--+data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir+                                         !MonitorStateFileStatus+  deriving (Show, Generic)++data MonitorStateFileStatus+   = MonitorStateFileExists+   | MonitorStateFileModTime !ModTime        -- ^ cached file mtime+   | MonitorStateFileHashed  !ModTime !Hash  -- ^ cached mtime and content hash+   | MonitorStateDirExists+   | MonitorStateDirModTime  !ModTime        -- ^ cached dir mtime+   | MonitorStateNonExistent+   | MonitorStateAlreadyChanged+  deriving (Show, Generic)++instance Binary MonitorStateFile+instance Binary MonitorStateFileStatus++-- | The state necessary to determine whether the files matched by a globbing+-- match have changed.+--+data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir+                                         !FilePathRoot !MonitorStateGlobRel+  deriving (Show, Generic)++data MonitorStateGlobRel+   = MonitorStateGlobDirs+       !Glob !FilePathGlobRel+       !ModTime+       ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted++   | MonitorStateGlobFiles+       !Glob+       !ModTime+       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted++   | MonitorStateGlobDirTrailing+  deriving (Show, Generic)++instance Binary MonitorStateGlob+instance Binary MonitorStateGlobRel++-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by+-- inspecting the state of the file system, and we can go in the reverse+-- direction by just forgetting the extra info.+--+reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]+reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =+    Map.foldrWithKey (\k x r -> getSinglePath k x : r)+                     (map getGlobPath globPaths)+                     singlePaths+  where+    getSinglePath filepath (MonitorStateFile kindfile kinddir _) =+      MonitorFile kindfile kinddir filepath++    getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =+      MonitorFileGlob kindfile kinddir $ FilePathGlob root $+        case gstate of+          MonitorStateGlobDirs  glob globs _ _ -> GlobDir  glob globs+          MonitorStateGlobFiles glob       _ _ -> GlobFile glob+          MonitorStateGlobDirTrailing          -> GlobDirTrailing++------------------------------------------------------------------------------+-- Checking the status of monitored files+--++-- | A monitor for detecting changes to a set of files. It can be used to+-- efficiently test if any of a set of files (specified individually or by+-- glob patterns) has changed since some snapshot. In addition, it also checks+-- for changes in a value (of type @a@), and when there are no changes in+-- either it returns a saved value (of type @b@).+--+-- The main use case looks like this: suppose we have some expensive action+-- that depends on certain pure inputs and reads some set of files, and+-- produces some pure result. We want to avoid re-running this action when it+-- would produce the same result. So we need to monitor the files the action+-- looked at, the other pure input values, and we need to cache the result.+-- Then at some later point, if the input value didn't change, and none of the+-- files changed, then we can re-use the cached result rather than re-running+-- the action.+--+-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance+-- saves state in a disk file, so the file for that has to be specified,+-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged'+-- to see if there's been any change. If there is, re-run the action, keeping+-- track of the files, then use 'updateFileMonitor' to record the current+-- set of files to monitor, the current input value for the action, and the+-- result of the action.+--+-- The typical occurrence of this pattern is captured by 'rerunIfChanged'+-- and the 'Rebuild' monad. More complicated cases may need to use+-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly.+--+data FileMonitor a b+   = FileMonitor {++       -- | The file where this 'FileMonitor' should store its state.+       --+       fileMonitorCacheFile :: FilePath,++       -- | Compares a new cache key with old one to determine if a+       -- corresponding cached value is still valid.+       --+       -- Typically this is just an equality test, but in some+       -- circumstances it can make sense to do things like subset+       -- comparisons.+       --+       -- The first arg is the new value, the second is the old cached value.+       --+       fileMonitorKeyValid :: a -> a -> Bool,++       -- | When this mode is enabled, if 'checkFileMonitorChanged' returns+       -- 'MonitoredValueChanged' then we have the guarantee that no files+       -- changed, that the value change was the only change. In the default+       -- mode no such guarantee is provided which is slightly faster.+       --+       fileMonitorCheckIfOnlyValueChanged :: Bool+  }++-- | Define a new file monitor.+--+-- It's best practice to define file monitor values once, and then use the+-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this+-- ensures you get the same types @a@ and @b@ for reading and writing.+--+-- The path of the file monitor itself must be unique because it keeps state+-- on disk and these would clash.+--+newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the+                                   -- file monitor. Must be unique.+                       -> FileMonitor a b+newFileMonitor path = FileMonitor path (==) False++-- | The result of 'checkFileMonitorChanged': either the monitored files or+-- value changed (and it tells us which it was) or nothing changed and we get+-- the cached result.+--+data MonitorChanged a b =+     -- | The monitored files and value did not change. The cached result is+     -- @b@.+     --+     -- The set of monitored files is also returned. This is useful+     -- for composing or nesting 'FileMonitor's.+     MonitorUnchanged b [MonitorFilePath]++     -- | The monitor found that something changed. The reason is given.+     --+   | MonitorChanged (MonitorChangedReason a)+  deriving Show++-- | What kind of change 'checkFileMonitorChanged' detected.+--+data MonitorChangedReason a =++     -- | One of the files changed (existence, file type, mtime or file+     -- content, depending on the 'MonitorFilePath' in question)+     MonitoredFileChanged FilePath++     -- | The pure input value changed.+     --+     -- The previous cached key value is also returned. This is sometimes+     -- useful when using a 'fileMonitorKeyValid' function that is not simply+     -- '(==)', when invalidation can be partial. In such cases it can make+     -- sense to 'updateFileMonitor' with a key value that's a combination of+     -- the new and old (e.g. set union).+   | MonitoredValueChanged a++     -- | There was no saved monitor state, cached value etc. Ie the file+     -- for the 'FileMonitor' does not exist.+   | MonitorFirstRun++     -- | There was existing state, but we could not read it. This typically+     -- happens when the code has changed compared to an existing 'FileMonitor'+     -- cache file and type of the input value or cached value has changed such+     -- that we cannot decode the values. This is completely benign as we can+     -- treat is just as if there were no cache file and re-run.+   | MonitorCorruptCache+  deriving (Eq, Show, Functor)++-- | Test if the input value or files monitored by the 'FileMonitor' have+-- changed. If not, return the cached value.+--+-- See 'FileMonitor' for a full explanation.+--+checkFileMonitorChanged+  :: (Binary a, Binary b)+  => FileMonitor a b            -- ^ cache file path+  -> FilePath                   -- ^ root directory+  -> a                          -- ^ guard or key value+  -> IO (MonitorChanged a b)    -- ^ did the key or any paths change?+checkFileMonitorChanged+    monitor@FileMonitor { fileMonitorKeyValid,+                          fileMonitorCheckIfOnlyValueChanged }+    root currentKey =++    -- Consider it a change if the cache file does not exist,+    -- or we cannot decode it. Sadly ErrorCall can still happen, despite+    -- using decodeFileOrFail, e.g. Data.Char.chr errors++    handleDoesNotExist (MonitorChanged MonitorFirstRun) $+    handleErrorCall    (MonitorChanged MonitorCorruptCache) $+          readCacheFile monitor+      >>= either (\_ -> return (MonitorChanged MonitorCorruptCache))+                 checkStatusCache++  where+    checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do+        change <- checkForChanges+        case change of+          Just reason -> return (MonitorChanged reason)+          Nothing     -> return (MonitorUnchanged cachedResult monitorFiles)+            where monitorFiles = reconstructMonitorFilePaths cachedFileStatus+      where+        -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that+        -- if we return MonitoredValueChanged that only the value changed.+        -- We do that by checkin for file changes first. Otherwise it makes+        -- more sense to do the cheaper test first.+        checkForChanges+          | fileMonitorCheckIfOnlyValueChanged+          = checkFileChange cachedFileStatus cachedKey cachedResult+              `mplusMaybeT`+            checkValueChange cachedKey++          | otherwise+          = checkValueChange cachedKey+              `mplusMaybeT`+            checkFileChange cachedFileStatus cachedKey cachedResult++    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    mplusMaybeT ma mb = do+      mx <- ma+      case mx of+        Nothing -> mb+        Just x  -> return (Just x)++    -- Check if the guard value has changed+    checkValueChange cachedKey+      | not (fileMonitorKeyValid currentKey cachedKey)+      = return (Just (MonitoredValueChanged cachedKey))+      | otherwise+      = return Nothing++    -- Check if any file has changed+    checkFileChange cachedFileStatus cachedKey cachedResult = do+      res <- probeFileSystem root cachedFileStatus+      case res of+        -- Some monitored file has changed+        Left changedPath ->+          return (Just (MonitoredFileChanged (normalise changedPath)))++        -- No monitored file has changed+        Right (cachedFileStatus', cacheStatus) -> do++          -- But we might still want to update the cache+          whenCacheChanged cacheStatus $+            rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult++          return Nothing++-- | Helper for reading the cache file.+--+-- This determines the type and format of the binary cache file.+--+readCacheFile :: (Binary a, Binary b)+              => FileMonitor a b+              -> IO (Either String (MonitorStateFileSet, a, b))+readCacheFile FileMonitor {fileMonitorCacheFile} =+    withBinaryFile fileMonitorCacheFile ReadMode $ \hnd ->+      Binary.decodeOrFailIO =<< BS.hGetContents hnd++-- | Helper for writing the cache file.+--+-- This determines the type and format of the binary cache file.+--+rewriteCacheFile :: (Binary a, Binary b)+                 => FileMonitor a b+                 -> MonitorStateFileSet -> a -> b -> IO ()+rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =+    writeFileAtomic fileMonitorCacheFile $+      Binary.encode (fileset, key, result)++-- | Probe the file system to see if any of the monitored files have changed.+--+-- It returns Nothing if any file changed, or returns a possibly updated+-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed.+--+-- We may need to update the cache since there may be changes in the filesystem+-- state which don't change any of our affected files.+--+-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a+-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run+-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then+-- we want to update the cache despite no changes in our relevant file set.+-- Specifically, we should add an mtime for this directory so we can avoid+-- re-traversing the directory in future runs.+--+probeFileSystem :: FilePath -> MonitorStateFileSet+                -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))+probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =+  runChangedM $ do+    sequence_+      [ probeMonitorStateFileStatus root file status+      | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ]+    -- The glob monitors can require state changes+    globPaths' <-+      sequence+        [ probeMonitorStateGlob root globPath+        | globPath <- globPaths ]+    return (MonitorStateFileSet singlePaths globPaths')+++-----------------------------------------------+-- Monad for checking for file system changes+--+-- We need to be able to bail out if we detect a change (using ExceptT),+-- but if there's no change we need to be able to rebuild the monitor+-- state. And we want to optimise that rebuilding by keeping track if+-- anything actually changed (using StateT), so that in the typical case+-- we can avoid rewriting the state file.++newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged))+runChangedM (ChangedM action) =+  runExceptT $ State.runStateT action CacheUnchanged++somethingChanged :: FilePath -> ChangedM a+somethingChanged path = ChangedM $ throwError path++cacheChanged :: ChangedM ()+cacheChanged = ChangedM $ State.put CacheChanged++mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a+mapChangedFile adjust (ChangedM a) =+    ChangedM (mapStateT (withExceptT adjust) a)++data CacheChanged = CacheChanged | CacheUnchanged++whenCacheChanged :: Monad m => CacheChanged -> m () -> m ()+whenCacheChanged CacheChanged action = action+whenCacheChanged CacheUnchanged _    = return ()++----------------------++-- | Probe the file system to see if a single monitored file has changed.+--+probeMonitorStateFileStatus :: FilePath -> FilePath+                            -> MonitorStateFileStatus+                            -> ChangedM ()+probeMonitorStateFileStatus root file status =+    case status of+      MonitorStateFileExists ->+        probeFileExistence root file++      MonitorStateFileModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateFileHashed  mtime hash ->+        probeFileModificationTimeAndHash root file mtime hash++      MonitorStateDirExists ->+        probeDirExistence root file++      MonitorStateDirModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateNonExistent ->+        probeFileNonExistence root file++      MonitorStateAlreadyChanged ->+        somethingChanged file+++-- | Probe the file system to see if a monitored file glob has changed.+--+probeMonitorStateGlob :: FilePath      -- ^ root path+                      -> MonitorStateGlob+                      -> ChangedM MonitorStateGlob+probeMonitorStateGlob relroot+                      (MonitorStateGlob kindfile kinddir globroot glob) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    case globroot of+      FilePathRelative ->+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "." glob++      -- for absolute cases, make the changed file we report absolute too+      _ ->+        mapChangedFile (root </>) $+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "" glob++probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir+                         -> FilePath      -- ^ root path+                         -> FilePath      -- ^ path of the directory we are+                                          --   looking in relative to @root@+                         -> MonitorStateGlobRel+                         -> ChangedM MonitorStateGlobRel+probeMonitorStateGlobRel kindfile kinddir root dirName+                        (MonitorStateGlobDirs glob globPath mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    case change of+      Nothing -> do+        children' <- sequence+          [ do fstate' <- probeMonitorStateGlobRel+                            kindfile kinddir root+                            (dirName </> fname) fstate+               return (fname, fstate')+          | (fname, fstate) <- children ]+        return $! MonitorStateGlobDirs glob globPath mtime children'++      Just mtime' -> do+        -- directory modification time changed:+        -- a matching subdir may have been added or deleted+        matches <- filterM (\entry -> let subdir = root </> dirName </> entry+                                       in liftIO $ doesDirectoryExist subdir)+                 . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        children' <- mapM probeMergeResult $+                          mergeBy (\(path1,_) path2 -> compare path1 path2)+                                  children+                                  (sort matches)+        return $! MonitorStateGlobDirs glob globPath mtime' children'+        -- Note that just because the directory has changed, we don't force+        -- a cache rewrite with 'cacheChanged' since that has some cost, and+        -- all we're saving is scanning the directory. But we do rebuild the+        -- cache with the new mtime', so that if the cache is rewritten for+        -- some other reason, we'll take advantage of that.++  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath+                     -> ChangedM (FilePath, MonitorStateGlobRel)++    -- Only in cached (directory deleted)+    probeMergeResult (OnlyInLeft (path, fstate)) = do+      case allMatchingFiles (dirName </> path) fstate of+        [] -> return (path, fstate)+        -- Strictly speaking we should be returning 'CacheChanged' above+        -- as we should prune the now-missing 'MonitorStateGlobRel'. However+        -- we currently just leave these now-redundant entries in the+        -- cache as they cost no IO and keeping them allows us to avoid+        -- rewriting the cache.+        (file:_) -> somethingChanged file++    -- Only in current filesystem state (directory added)+    probeMergeResult (OnlyInRight path) = do+      fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty+                           kindfile kinddir root (dirName </> path) globPath+      case allMatchingFiles (dirName </> path) fstate of+        (file:_) -> somethingChanged file+        -- This is the only case where we use 'cacheChanged' because we can+        -- have a whole new dir subtree (of unbounded size and cost), so we+        -- need to save the state of that new subtree in the cache.+        [] -> cacheChanged >> return (path, fstate)++    -- Found in path+    probeMergeResult (InBoth (path, fstate) _) = do+      fstate' <- probeMonitorStateGlobRel kindfile kinddir+                                          root (dirName </> path) fstate+      return (path, fstate')++    -- | Does a 'MonitorStateGlob' have any relevant files within it?+    allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]+    allMatchingFiles dir (MonitorStateGlobFiles _ _   entries) =+      [ dir </> fname | (fname, _) <- entries ]+    allMatchingFiles dir (MonitorStateGlobDirs  _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- allMatchingFiles (dir </> subdir) fstate ]+    allMatchingFiles dir MonitorStateGlobDirTrailing =+      [dir]++probeMonitorStateGlobRel _ _ root dirName+                         (MonitorStateGlobFiles glob mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    mtime' <- case change of+      Nothing     -> return mtime+      Just mtime' -> do+        -- directory modification time changed:+        -- a matching file may have been added or deleted+        matches <- return . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        mapM_ probeMergeResult $+              mergeBy (\(path1,_) path2 -> compare path1 path2)+                      children+                      (sort matches)+        return mtime'++    -- Check that none of the children have changed+    forM_ children $ \(file, status) ->+      probeMonitorStateFileStatus root (dirName </> file) status+++    return (MonitorStateGlobFiles glob mtime' children)+    -- Again, we don't force a cache rewite with 'cacheChanged', but we do use+    -- the new mtime' if any.+  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath+                     -> ChangedM ()+    probeMergeResult mr = case mr of+      InBoth _ _            -> return ()+    -- this is just to be able to accurately report which file changed:+      OnlyInLeft  (path, _) -> somethingChanged (dirName </> path)+      OnlyInRight path      -> somethingChanged (dirName </> path)++probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =+    return MonitorStateGlobDirTrailing++------------------------------------------------------------------------------++-- | Update the input value and the set of files monitored by the+-- 'FileMonitor', plus the cached value that may be returned in future.+--+-- This takes a snapshot of the state of the monitored files right now, so+-- 'checkFileMonitorChanged' will look for file system changes relative to+-- this snapshot.+--+-- This is typically done once the action has been completed successfully and+-- we have the action's result and we know what files it looked at. See+-- 'FileMonitor' for a full explanation.+--+-- If we do take the snapshot after the action has completed then we have a+-- problem. The problem is that files might have changed /while/ the action was+-- running but /after/ the action read them. If we take the snapshot after the+-- action completes then we will miss these changes. The solution is to record+-- a timestamp before beginning execution of the action and then we make the+-- conservative assumption that any file that has changed since then has+-- already changed, ie the file monitor state for these files will be such that+-- 'checkFileMonitorChanged' will report that they have changed.+--+-- So if you do use 'updateFileMonitor' after the action (so you can discover+-- the files used rather than predicting them in advance) then use+-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively,+-- if you take the snapshot in advance of the action, or you're not monitoring+-- any files then you can use @Nothing@ for the timestamp parameter.+--+updateFileMonitor+  :: (Binary a, Binary b)+  => FileMonitor a b          -- ^ cache file path+  -> FilePath                 -- ^ root directory+  -> Maybe MonitorTimestamp   -- ^ timestamp when the update action started+  -> [MonitorFilePath]        -- ^ files of interest relative to root+  -> a                        -- ^ the current key value+  -> b                        -- ^ the current result value+  -> IO ()+updateFileMonitor monitor root startTime monitorFiles+                  cachedKey cachedResult = do+    hashcache <- readCacheFileHashes monitor+    msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles+    rewriteCacheFile monitor msfs cachedKey cachedResult++-- | A timestamp to help with the problem of file changes during actions.+-- See 'updateFileMonitor' for details.+--+newtype MonitorTimestamp = MonitorTimestamp ModTime++-- | Record a timestamp at the beginning of an action, and when the action+-- completes call 'updateFileMonitor' passing it the timestamp.+-- See 'updateFileMonitor' for details.+--+beginUpdateFileMonitor :: IO MonitorTimestamp+beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime++-- | Take the snapshot of the monitored files. That is, given the+-- specification of the set of files we need to monitor, inspect the state+-- of the file system now and collect the information we'll need later to+-- determine if anything has changed.+--+buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp+                                              -- of the start of the action+                         -> FileHashCache     -- ^ existing file hashes+                         -> FilePath          -- ^ root directory+                         -> [MonitorFilePath] -- ^ patterns of interest+                                              --   relative to root+                         -> IO MonitorStateFileSet+buildMonitorStateFileSet mstartTime hashcache root =+    go Map.empty []+  where+    go :: Map FilePath MonitorStateFile -> [MonitorStateGlob]+       -> [MonitorFilePath] -> IO MonitorStateFileSet+    go !singlePaths !globPaths [] =+      return (MonitorStateFileSet singlePaths globPaths)++    go !singlePaths !globPaths+       (MonitorFile kindfile kinddir path : monitors) = do+      monitorState <- MonitorStateFile kindfile kinddir+                  <$> buildMonitorStateFile mstartTime hashcache+                                            kindfile kinddir root path+      go (Map.insert path monitorState singlePaths) globPaths monitors++    go !singlePaths !globPaths+       (MonitorFileGlob kindfile kinddir globPath : monitors) = do+      monitorState <- buildMonitorStateGlob mstartTime hashcache+                                            kindfile kinddir root globPath+      go singlePaths (monitorState : globPaths) monitors+++buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache          -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath               -- ^ the root directory+                      -> FilePath+                      -> IO MonitorStateFileStatus+buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do+    let abspath = root </> path+    isFile <- doesFileExist abspath+    isDir  <- doesDirectoryExist abspath+    case (isFile, kindfile, isDir, kinddir) of+      (_, FileNotExists, _, DirNotExists) ->+        -- we don't need to care if it exists now, since we check at probe time+        return MonitorStateNonExistent++      (False, _, False, _) ->+        return MonitorStateAlreadyChanged++      (True, FileExists, _, _)  ->+        return MonitorStateFileExists++      (True, FileModTime, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateFileModTime mtime)++      (True, FileHashed, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else do hash <- getFileHash hashcache abspath abspath mtime+                    return (MonitorStateFileHashed mtime hash)++      (_, _, True, DirExists) ->+        return MonitorStateDirExists++      (_, _, True, DirModTime) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateDirModTime mtime)++      (False, _, True,  DirNotExists) -> return MonitorStateAlreadyChanged+      (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged++-- | If we have a timestamp for the beginning of the update, then any file+-- mtime later than this means that it changed during the update and we ought+-- to consider the file as already changed.+--+changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool+changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime+                        = mtime > startTime+changedDuringUpdate _ _ = False++-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case+-- of a file glob.+--+-- This gets used both by 'buildMonitorStateFileSet' when we're taking the+-- file system snapshot, but also by 'probeGlobStatus' as part of checking+-- the monitored (globed) files for changes when we find a whole new subtree.+--+buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache     -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath     -- ^ the root directory+                      -> FilePathGlob -- ^ the matching glob+                      -> IO MonitorStateGlob+buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot+                      (FilePathGlob globroot globPath) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    MonitorStateGlob kindfile kinddir globroot <$>+      buildMonitorStateGlobRel+        mstartTime hashcache kindfile kinddir root "." globPath++buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update+                         -> FileHashCache   -- ^ existing file hashes+                         -> MonitorKindFile -> MonitorKindDir+                         -> FilePath        -- ^ the root directory+                         -> FilePath        -- ^ directory we are examining+                                            --   relative to the root+                         -> FilePathGlobRel -- ^ the matching glob+                         -> IO MonitorStateGlobRel+buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root+                         dir globPath = do+    let absdir = root </> dir+    dirEntries <- getDirectoryContents absdir+    dirMTime   <- getModTime absdir+    case globPath of+      GlobDir glob globPath' -> do+        subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))+                 $ filter (matchGlob glob) dirEntries+        subdirStates <-+          forM (sort subdirs) $ \subdir -> do+            fstate <- buildMonitorStateGlobRel+                        mstartTime hashcache kindfile kinddir root+                        (dir </> subdir) globPath'+            return (subdir, fstate)+        return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates++      GlobFile glob -> do+        let files = filter (matchGlob glob) dirEntries+        filesStates <-+          forM (sort files) $ \file -> do+            fstate <- buildMonitorStateFile+                        mstartTime hashcache kindfile kinddir root+                        (dir </> file)+            return (file, fstate)+        return $! MonitorStateGlobFiles glob dirMTime filesStates++      GlobDirTrailing ->+        return MonitorStateGlobDirTrailing+++-- | We really want to avoid re-hashing files all the time. We already make+-- the assumption that if a file mtime has not changed then we don't need to+-- bother checking if the content hash has changed. We can apply the same+-- assumption when updating the file monitor state. In the typical case of+-- updating a file monitor the set of files is the same or largely the same so+-- we can grab the previously known content hashes with their corresponding+-- mtimes.+--+type FileHashCache = Map FilePath (ModTime, Hash)++-- | We declare it a cache hit if the mtime of a file is the same as before.+--+lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash+lookupFileHashCache hashcache file mtime = do+    (mtime', hash) <- Map.lookup file hashcache+    guard (mtime' == mtime)+    return hash++-- | Either get it from the cache or go read the file+getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash+getFileHash hashcache relfile absfile mtime =+    case lookupFileHashCache hashcache relfile mtime of+      Just hash -> return hash+      Nothing   -> readFileHash absfile++-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While+-- in principle we could preserve the structure of the previous state, given+-- that the set of files to monitor can change then it's simpler just to throw+-- away the structure and use a finite map.+--+readCacheFileHashes :: (Binary a, Binary b)+                    => FileMonitor a b -> IO FileHashCache+readCacheFileHashes monitor =+    handleDoesNotExist Map.empty $+    handleErrorCall    Map.empty $ do+      res <- readCacheFile monitor+      case res of+        Left _             -> return Map.empty+        Right (msfs, _, _) -> return (mkFileHashCache msfs)+  where+    mkFileHashCache :: MonitorStateFileSet -> FileHashCache+    mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =+                    collectAllFileHashes singlePaths+        `Map.union` collectAllGlobHashes globPaths++    collectAllFileHashes =+      Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of+        MonitorStateFileHashed mtime hash -> Just (mtime, hash)+        _                                 -> Nothing++    collectAllGlobHashes globPaths =+      Map.fromList [ (fpath, hash)+                   | MonitorStateGlob _ _ _ gstate <- globPaths+                   , (fpath, hash) <- collectGlobHashes "" gstate ]++    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- collectGlobHashes (dir </> subdir) fstate ]++    collectGlobHashes dir (MonitorStateGlobFiles  _ _ entries) =+      [ (dir </> fname, (mtime, hash))+      | (fname, MonitorStateFileHashed mtime hash) <- entries ]++    collectGlobHashes _dir MonitorStateGlobDirTrailing =+      []+++------------------------------------------------------------------------------+-- Utils+--++-- | Within the @root@ directory, check if @file@ has its 'ModTime' is+-- the same as @mtime@, short-circuiting if it is different.+probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM ()+probeFileModificationTime root file mtime = do+    unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ has its 'ModTime' and+-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is+-- different.+probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash+                                 -> ChangedM ()+probeFileModificationTimeAndHash root file mtime hash = do+    unchanged <- liftIO $+      checkFileModificationTimeAndHashUnchanged root file mtime hash+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ still exists as a file.+-- If it *does not* exist, short-circuit.+probeFileExistence :: FilePath -> FilePath -> ChangedM ()+probeFileExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    unless existsFile (somethingChanged file)++-- | Within the @root@ directory, check if @dir@ still exists.+-- If it *does not* exist, short-circuit.+probeDirExistence :: FilePath -> FilePath -> ChangedM ()+probeDirExistence root dir = do+    existsDir  <- liftIO $ doesDirectoryExist (root </> dir)+    unless existsDir (somethingChanged dir)++-- | Within the @root@ directory, check if @file@ still does not exist.+-- If it *does* exist, short-circuit.+probeFileNonExistence :: FilePath -> FilePath -> ChangedM ()+probeFileNonExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    existsDir  <- liftIO $ doesDirectoryExist (root </> file)+    when (existsFile || existsDir) (somethingChanged file)++-- | Returns @True@ if, inside the @root@ directory, @file@ has the same+-- 'ModTime' as @mtime@.+checkModificationTimeUnchanged :: FilePath -> FilePath+                               -> ModTime -> IO Bool+checkModificationTimeUnchanged root file mtime =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    return (mtime == mtime')++-- | Returns @True@ if, inside the @root@ directory, @file@ has the+-- same 'ModTime' and 'Hash' as @mtime and @chash@.+checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath+                                          -> ModTime -> Hash -> IO Bool+checkFileModificationTimeAndHashUnchanged root file mtime chash =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    if mtime == mtime'+      then return True+      else do+        chash' <- readFileHash (root </> file)+        return (chash == chash')++-- | Read a non-cryptographic hash of a @file@.+readFileHash :: FilePath -> IO Hash+readFileHash file =+    withBinaryFile file ReadMode $ \hnd ->+      evaluate . Hashable.hash =<< BS.hGetContents hnd++-- | Given a directory @dir@, return @Nothing@ if its 'ModTime'+-- is the same as @mtime@, and the new 'ModTime' if it is not.+checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime)+checkDirectoryModificationTime dir mtime =+  handleIOException Nothing $ do+    mtime' <- getModTime dir+    if mtime == mtime'+      then return Nothing+      else return (Just mtime')++-- | Run an IO computation, returning @e@ if there is an 'error'+-- call. ('ErrorCall')+handleErrorCall :: a -> IO a -> IO a+handleErrorCall e =+    handle (\(ErrorCall _) -> return e)++-- | Run an IO computation, returning @e@ if there is any 'IOException'.+--+-- This policy is OK in the file monitor code because it just causes the+-- monitor to report that something changed, and then code reacting to that+-- will normally encounter the same IO exception when it re-runs the action+-- that uses the file.+--+handleIOException :: a -> IO a -> IO a+handleIOException e =+    handle (anyIOException e)+  where+    anyIOException :: a -> IOException -> IO a+    anyIOException x _ = return x+++------------------------------------------------------------------------------+-- Instances+--++instance Binary MonitorStateFileSet where+  put (MonitorStateFileSet singlePaths globPaths) = do+    put (1 :: Int) -- version+    put singlePaths+    put globPaths+  get = do+    ver <- get+    if ver == (1 :: Int)+      then do singlePaths <- get+              globPaths   <- get+              return $! MonitorStateFileSet singlePaths globPaths+      else fail "MonitorStateFileSet: wrong version"
Distribution/Client/Freeze.hs view
@@ -13,20 +13,25 @@ -- The cabal freeze command ----------------------------------------------------------------------------- module Distribution.Client.Freeze (-    freeze,+    freeze, getFreezePkgs   ) where  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-         ( PlanPackage )+         ( InstallPlan, PlanPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup-         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )+         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)+         , RepoContext(..) ) import Distribution.Client.Sandbox.PackageEnvironment          ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,            userPackageEnvironmentFile )@@ -34,15 +39,14 @@          ( SandboxPackageInfo(..) )  import Distribution.Package-         ( Package, PackageIdentifier, packageId, packageName, packageVersion )+         ( Package, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler          ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup-         ( fromFlag, fromFlagOrDefault )+         ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils          ( die, notice, debug, writeFileAtomic ) import Distribution.System@@ -73,7 +77,7 @@ -- freeze :: Verbosity       -> PackageDBStack-      -> [Repo]+      -> RepoContext       -> Compiler       -> Platform       -> ProgramConfiguration@@ -81,21 +85,12 @@       -> GlobalFlags       -> FreezeFlags       -> IO ()-freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo+freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo       globalFlags freezeFlags = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos--    pkgSpecifiers <- resolveUserTargets verbosity-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       [UserTargetLocalDir "."]--    sanityCheck pkgSpecifiers-    pkgs  <- planPackages-               verbosity comp platform mSandboxPkgInfo freezeFlags-               installedPkgIndex sourcePkgDb pkgSpecifiers+    pkgs  <- getFreezePkgs+               verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+               globalFlags freezeFlags      if null pkgs       then notice verbosity $ "No packages to be frozen. "@@ -105,11 +100,40 @@                      "The following packages would be frozen:"                    : formatPkgs pkgs -             else freezePackages verbosity pkgs+             else freezePackages verbosity globalFlags pkgs    where     dryRun = fromFlag (freezeDryRun freezeFlags) +-- | Get the list of packages whose versions would be frozen by the @freeze@+-- command.+getFreezePkgs :: Verbosity+              -> PackageDBStack+              -> RepoContext+              -> Compiler+              -> Platform+              -> ProgramConfiguration+              -> Maybe SandboxPackageInfo+              -> GlobalFlags+              -> FreezeFlags+              -> IO [PlanPackage]+getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+      globalFlags freezeFlags = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf++    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       [UserTargetLocalDir "."]++    sanityCheck pkgSpecifiers+    planPackages+               verbosity comp platform mSandboxPkgInfo freezeFlags+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers+  where     sanityCheck pkgSpecifiers = do       when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $         die $ "internal error: 'resolveUserTargets' returned "@@ -125,10 +149,11 @@              -> FreezeFlags              -> InstalledPackageIndex              -> SourcePackageDb+             -> PkgConfigDb              -> [PackageSpecifier SourcePackage]              -> IO [PlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers = do+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do    solver <- chooseSolver verbosity             (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)@@ -136,13 +161,11 @@    installPlan <- foldProgress logMsg die return $                    resolveDependencies-                     platform (compilerInfo comp)+                     platform (compilerInfo comp) pkgConfigDb                      solver                      resolverParams -  return $ either id-                  (error "planPackages: installPlan contains broken packages")-                  (pruneInstallPlan installPlan pkgSpecifiers)+  return $ pruneInstallPlan installPlan pkgSpecifiers    where     resolverParams =@@ -159,7 +182,9 @@       . setStrongFlags strongFlags        . addConstraints-          [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas+          [ let pkg = pkgSpecifierTarget pkgSpecifier+                pc = PackageConstraintStanzas pkg stanzas+            in LabeledPackageConstraint pc ConstraintSourceFreeze           | pkgSpecifier <- pkgSpecifiers ]        . maybe id applySandboxInstallPolicy mSandboxPkgInfo@@ -168,10 +193,8 @@      logMsg message rest = debug verbosity message >> rest -    stanzas = concat-        [ if testsEnabled      then [TestStanzas]  else []-        , if benchmarksEnabled then [BenchStanzas] else []-        ]+    stanzas = [ TestStanzas | testsEnabled ]+           ++ [ BenchStanzas | benchmarksEnabled ]     testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags     benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags @@ -191,40 +214,39 @@ -- 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.InstallPlan+pruneInstallPlan :: InstallPlan                  -> [PackageSpecifier SourcePackage]-                 -> Either [PlanPackage] [(PlanPackage, [PackageIdentifier])]+                 -> [PlanPackage] pruneInstallPlan installPlan pkgSpecifiers =-    mapLeft (removeSelf pkgIds . PackageIndex.allPackages) $-    PackageIndex.dependencyClosure pkgIdx pkgIds+    removeSelf pkgIds $+    InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)   where-    pkgIdx = PackageIndex.fromList $ InstallPlan.toList installPlan-    pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]-    mapLeft f (Left v)  = Left $ f v-    mapLeft _ (Right v) = Right v-    removeSelf [thisPkg] = filter (\pp -> packageId pp /= thisPkg)-    removeSelf _ =-        error $ "internal error: 'pruneInstallPlan' given "-           ++ "unexpected package specifiers!"+    pkgIds = [ packageId pkg+             | SpecificSourcePackage pkg <- pkgSpecifiers ]+    removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)+    removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "+                         ++ "unexpected package specifiers!"  -freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()-freezePackages verbosity pkgs = do+freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()+freezePackages verbosity globalFlags pkgs = do+     pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $-                   loadUserConfig verbosity ""+                   loadUserConfig verbosity ""  (flagToMaybe . globalConstraintsFile $ globalFlags)     writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv   where     addFrozenConstraints config =         config {             savedConfigureExFlags = (savedConfigureExFlags config) {-                configExConstraints = constraints pkgs+                configExConstraints = map constraint pkgs             }         }-    constraints = map $ pkgIdToConstraint . packageId+    constraint pkg =+        (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)       where-        pkgIdToConstraint pkg =-            UserConstraintVersion (packageName pkg)-                                  (thisVersion $ packageVersion pkg)+        pkgIdToConstraint pkgId =+            UserConstraintVersion (packageName pkgId)+                                  (thisVersion $ packageVersion pkgId)     createPkgEnv config = mempty { pkgEnvSavedConfig = config }     showPkgEnv = BS.Char8.pack . showPackageEnvironment
+ Distribution/Client/GenBounds.hs view
@@ -0,0 +1,159 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GenBounds+-- Copyright   :  (c) Doug Beardsley 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal gen-bounds command for generating PVP-compliant version bounds.+-----------------------------------------------------------------------------+module Distribution.Client.GenBounds (+    genBounds+  ) where++import Data.Version+         ( Version(..), showVersion )+import Distribution.Client.Init+         ( incVersion )+import Distribution.Client.Freeze+         ( getFreezePkgs )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..), RepoContext )+import Distribution.Package+         ( Package(..), Dependency(..), PackageName(..)+         , packageName, packageVersion )+import Distribution.PackageDescription+         ( buildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack, compilerInfo )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Utils+         ( tryFindPackageDesc )+import Distribution.System+         ( Platform )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Version+         ( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals+         , orLaterVersion, earlierVersion, intersectVersionRanges )+import System.Directory+         ( getCurrentDirectory )++-- | Does this version range have an upper bound?+hasUpperBound :: VersionRange -> Bool+hasUpperBound vr =+    case asVersionIntervals vr of+      [] -> False+      is -> if snd (last is) == NoUpperBound then False else True++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.+--+-- This version is slightly different than the one in+-- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because+-- the user could be using a new function introduced in a.b.c which would make+-- ">= a.b" incorrect.+pvpize :: Version -> VersionRange+pvpize v = orLaterVersion (vn 3)+           `intersectVersionRanges`+           earlierVersion (incVersion 1 (vn 2))+  where+    vn n = (v { versionBranch = take n (versionBranch v) })++-- | Show the PVP-mandated version range for this package. The @padTo@ parameter+-- specifies the width of the package name column.+showBounds :: Package pkg => Int -> pkg -> String+showBounds padTo p = unwords $+    (padAfter padTo $ unPackageName $ packageName p) :+    map showInterval (asVersionIntervals $ pvpize $ packageVersion p)+  where+    padAfter :: Int -> String -> String+    padAfter n str = str ++ replicate (n - length str) ' '++    showInterval :: (LowerBound, UpperBound) -> String+    showInterval (LowerBound _ _, NoUpperBound) =+      error "Error: expected upper bound...this should never happen!"+    showInterval (LowerBound l _, UpperBound u _) =+      unwords [">=", showVersion l, "&& <", showVersion u]++-- | Entry point for the @gen-bounds@ command.+genBounds+    :: Verbosity+    -> PackageDBStack+    -> RepoContext+    -> Compiler+    -> Platform+    -> ProgramConfiguration+    -> Maybe SandboxPackageInfo+    -> GlobalFlags+    -> FreezeFlags+    -> IO ()+genBounds verbosity packageDBs repoCtxt comp platform conf 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+    case epd of+      Left _ -> putStrLn "finalizePackageDescription failed"+      Right (pd,_) -> do+        let needBounds = filter (not . hasUpperBound . depVersion) $+                         buildDepends pd++        if (null needBounds)+          then putStrLn+               "Congratulations, all your dependencies have upper bounds!"+          else go needBounds+  where+     go needBounds = do+       pkgs  <- getFreezePkgs+                  verbosity packageDBs repoCtxt comp platform conf+                  mSandboxPkgInfo globalFlags freezeFlags++       putStrLn boundsNeededMsg++       let isNeeded pkg = unPackageName (packageName pkg)+                          `elem` map depName needBounds+       let thePkgs = filter isNeeded pkgs++       let padTo = maximum $ map (length . unPackageName . packageName) pkgs+       mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs++     depName :: Dependency -> String+     depName (Dependency (PackageName nm) _) = nm++     depVersion :: Dependency -> VersionRange+     depVersion (Dependency _ vr) = vr++-- | The message printed when some dependencies are found to be lacking proper+-- PVP-mandated bounds.+boundsNeededMsg :: String+boundsNeededMsg = unlines+  [ ""+  , "The following packages need bounds and here is a suggested starting point."+  , "You can copy and paste this into the build-depends section in your .cabal"+  , "file and it should work (with the appropriate removal of commas)."+  , ""+  , "Note that version bounds are a statement that you've successfully built and"+  , "tested your package and expect it to work with any of the specified package"+  , "versions (PROVIDED that those packages continue to conform with the PVP)."+  , "Therefore, the version bounds generated here are the most conservative"+  , "based on the versions that you are currently building with.  If you know"+  , "your package will work with versions outside the ranges generated here,"+  , "feel free to widen them."+  , ""+  ]
Distribution/Client/Get.hs view
@@ -30,7 +30,7 @@ import qualified Distribution.PackageDescription as PD  import Distribution.Client.Setup-         ( GlobalFlags(..), GetFlags(..) )+         ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency@@ -72,7 +72,7 @@  -- | Entry point for the 'cabal get' command. get :: Verbosity-    -> [Repo]+    -> RepoContext     -> GlobalFlags     -> GetFlags     -> [UserTarget]@@ -80,7 +80,7 @@ get verbosity _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -get verbosity repos globalFlags getFlags userTargets = do+get verbosity repoCtxt globalFlags getFlags userTargets = do   let useFork = case (getSourceRepository getFlags) of         NoFlag -> False         _      -> True@@ -88,9 +88,9 @@   unless useFork $     mapM_ checkTarget userTargets -  sourcePkgDb <- getSourcePackages verbosity repos+  sourcePkgDb <- getSourcePackages verbosity repoCtxt -  pkgSpecifiers <- resolveUserTargets verbosity+  pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                    (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)                    userTargets@@ -122,7 +122,7 @@     unpack :: [SourcePackage] -> IO ()     unpack pkgs = do       forM_ pkgs $ \pkg -> do-        location <- fetchPackage verbosity (packageSource pkg)+        location <- fetchPackage verbosity repoCtxt (packageSource pkg)         let pkgid = packageId pkg             descOverride | usePristine = Nothing                          | otherwise   = packageDescrOverride pkg
+ Distribution/Client/Glob.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP, DeriveGeneric #-}++--TODO: [code cleanup] plausibly much of this module should be merged with+-- similar functionality in Cabal.+module Distribution.Client.Glob+    ( FilePathGlob(..)+    , FilePathRoot(..)+    , FilePathGlobRel(..)+    , Glob+    , GlobPiece(..)+    , matchFileGlob+    , matchFileGlobRel+    , matchGlob+    , isTrivialFilePathGlob+    , getFilePathRootDirectory+    ) where++import           Data.Char (toUpper)+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           Distribution.Text+import           Distribution.Compat.ReadP (ReadP, (<++), (+++))+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp++import           System.FilePath+import           System.Directory+++-- | A file path specified by globbing+--+data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel+  deriving (Eq, Show, Generic)++data FilePathGlobRel+   = GlobDir  !Glob !FilePathGlobRel+   | GlobFile !Glob+   | GlobDirTrailing                -- ^ trailing dir, a glob ending in @/@+  deriving (Eq, Show, Generic)++-- | A single directory or file component of a globbed path+type Glob = [GlobPiece]++-- | A piece of a globbing pattern+data GlobPiece = WildCard+               | Literal String+               | Union [Glob]+  deriving (Eq, Show, Generic)++data FilePathRoot+   = FilePathRelative+   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'+   | FilePathHomeDir+  deriving (Eq, Show, Generic)++instance Binary FilePathGlob+instance Binary FilePathRoot+instance Binary FilePathGlobRel+instance Binary GlobPiece+++-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and+-- is in fact equivalent to a non-glob 'FilePath'.+--+-- If it is trivial in this sense then the result is the equivalent constant+-- 'FilePath'. On the other hand if it is not trivial (so could in principle+-- match more than one file) then the result is @Nothing@.+--+isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath+isTrivialFilePathGlob (FilePathGlob root pathglob) =+    case root of+      FilePathRelative       -> go []      pathglob+      FilePathRoot root'     -> go [root'] pathglob+      FilePathHomeDir        -> Nothing+  where+    go paths (GlobDir  [Literal path] globs) = go (path:paths) globs+    go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))+    go paths  GlobDirTrailing          = Just (addTrailingPathSeparator+                                                 (joinPath (reverse paths)))+    go _ _ = Nothing++-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.+--+-- The 'FilePath' argument is required to supply the path for the+-- 'FilePathRelative' case.+--+getFilePathRootDirectory :: FilePathRoot+                         -> FilePath      -- ^ root for relative paths+                         -> IO FilePath+getFilePathRootDirectory  FilePathRelative   root = return root+getFilePathRootDirectory (FilePathRoot root) _    = return root+getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory+++------------------------------------------------------------------------------+-- Matching+--++-- | Match a 'FilePathGlob' against the file system, starting from a given+-- root directory for relative paths. The results of relative globs are+-- relative to the given root. Matches for absolute globs are absolute.+--+matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]+matchFileGlob relroot (FilePathGlob globroot glob) = do+    root <- getFilePathRootDirectory globroot relroot+    matches <- matchFileGlobRel root glob+    case globroot of+      FilePathRelative -> return matches+      _                -> return (map (root </>) matches)++-- | Match a 'FilePathGlobRel' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]+matchFileGlobRel root glob0 = go glob0 ""+  where+    go (GlobFile glob) dir = do+      entries <- getDirectoryContents (root </> dir)+      let files = filter (matchGlob glob) entries+      return (map (dir </>) files)++    go (GlobDir glob globPath) dir = do+      entries <- getDirectoryContents (root </> dir)+      subdirs <- filterM (\subdir -> doesDirectoryExist+                                       (root </> dir </> subdir))+               $ filter (matchGlob glob) entries+      concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs++    go GlobDirTrailing dir = return [dir]+++-- | Match a globbing pattern against a file path component+--+matchGlob :: Glob -> String -> Bool+matchGlob = goStart+  where+    -- From the man page, glob(7):+    --   "If a filename starts with a '.', this character must be+    --    matched explicitly."++    go, goStart :: [GlobPiece] -> String -> Bool++    goStart (WildCard:_) ('.':_)  = False+    goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)+                                        globs+    goStart rest               cs = go rest cs++    go []                 ""    = True+    go (Literal lit:rest) cs+      | Just cs' <- stripPrefix lit cs+                                = go rest cs'+      | otherwise               = False+    go [WildCard]         ""    = True+    go (WildCard:rest)   (c:cs) = go rest (c:cs) || go (WildCard:rest) cs+    go (Union globs:rest)   cs  = any (\glob -> go (glob ++ rest) cs) globs+    go []                (_:_)  = False+    go (_:_)              ""    = False+++------------------------------------------------------------------------------+-- Parsing & printing+--++instance Text FilePathGlob where+  disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob+  parse =+    parse >>= \root ->+        (FilePathGlob root <$> parse)+    <++ (when (root == FilePathRelative) Parse.pfail >>+         return (FilePathGlob root GlobDirTrailing))++instance Text FilePathRoot where+  disp  FilePathRelative    = Disp.empty+  disp (FilePathRoot root)  = Disp.text root+  disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'++  parse =+        (     (Parse.char '/' >> return (FilePathRoot "/"))+          +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)+          +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')+                                             || (c >= 'A' && c <= 'Z'))+                  _ <- Parse.char ':'+                  _ <- Parse.char '/' +++ Parse.char '\\'+                  return (FilePathRoot (toUpper drive : ":\\")))+        )+    <++ return FilePathRelative++instance Text FilePathGlobRel where+  disp (GlobDir  glob pathglob) = dispGlob glob+                          Disp.<> Disp.char '/'+                          Disp.<> disp pathglob+  disp (GlobFile glob)          = dispGlob glob+  disp  GlobDirTrailing         = Disp.empty++  parse = parsePath+    where+      parsePath :: ReadP r FilePathGlobRel+      parsePath =+        parseGlob >>= \globpieces ->+            asDir globpieces+        <++ asTDir globpieces+        <++ asFile globpieces++      asDir  glob = do dirSep+                       globs <- parsePath+                       return (GlobDir glob globs)+      asTDir glob = do dirSep+                       return (GlobDir glob GlobDirTrailing)+      asFile glob = return (GlobFile glob)++      dirSep = (Parse.char '/' >> return ())+           +++ (do _ <- Parse.char '\\'+                   -- check this isn't an escape code+                   following <- Parse.look+                   case following of+                     (c:_) | isGlobEscapedChar c -> Parse.pfail+                     _                           -> return ())+++dispGlob :: Glob -> Disp.Doc+dispGlob = Disp.hcat . map dispPiece+  where+    dispPiece WildCard      = Disp.char '*'+    dispPiece (Literal str) = Disp.text (escape str)+    dispPiece (Union globs) = Disp.braces+                                (Disp.hcat (Disp.punctuate+                                             (Disp.char ',')+                                             (map dispGlob globs)))+    escape []               = []+    escape (c:cs)+      | isGlobEscapedChar c = '\\' : c : escape cs+      | otherwise           =        c : escape cs++parseGlob :: ReadP r Glob+parseGlob = Parse.many1 parsePiece+  where+    parsePiece = literal +++ wildcard +++ union++    wildcard = Parse.char '*' >> return WildCard++    union = Parse.between (Parse.char '{') (Parse.char '}') $+              fmap Union (Parse.sepBy1 parseGlob (Parse.char ','))++    literal = Literal `fmap` litchars1++    litchar = normal +++ escape++    normal  = Parse.satisfy (\c -> not (isGlobEscapedChar c)+                                && c /= '/' && c /= '\\')+    escape  = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar++    litchars1 :: ReadP r [Char]+    litchars1 = liftM2 (:) litchar litchars++    litchars :: ReadP r [Char]+    litchars = litchars1 <++ return []++isGlobEscapedChar :: Char -> Bool+isGlobEscapedChar '*'  = True+isGlobEscapedChar '{'  = True+isGlobEscapedChar '}'  = True+isGlobEscapedChar ','  = True+isGlobEscapedChar _    = False
+ Distribution/Client/GlobalFlags.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.GlobalFlags (+    GlobalFlags(..)+  , defaultGlobalFlags+  , RepoContext(..)+  , withRepoContext+  , withRepoContext'+  ) where++import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..) )+import Distribution.Compat.Semigroup+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, flagToMaybe )+import Distribution.Utils.NubList+         ( NubList, fromNubList )+import Distribution.Client.HttpUtils+         ( HttpTransport, configureTransport )+import Distribution.Verbosity+         ( Verbosity )+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 )+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+import qualified Hackage.Security.Util.Pretty               as Sec+import qualified Hackage.Security.Client.Repository.Cache   as Sec+import qualified Hackage.Security.Client.Repository.Local   as Sec.Local+import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote+import qualified Distribution.Client.Security.HTTP          as Sec.HTTP++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+    globalVersion           :: Flag Bool,+    globalNumericVersion    :: Flag Bool,+    globalConfigFile        :: Flag FilePath,+    globalSandboxConfigFile :: Flag FilePath,+    globalConstraintsFile   :: Flag FilePath,+    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.+    globalCacheDir          :: Flag FilePath,+    globalLocalRepos        :: NubList FilePath,+    globalLogsDir           :: Flag FilePath,+    globalWorldFile         :: Flag FilePath,+    globalRequireSandbox    :: Flag Bool,+    globalIgnoreSandbox     :: Flag Bool,+    globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates+    globalHttpTransport     :: Flag String+  } deriving Generic++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion           = Flag False,+    globalNumericVersion    = Flag False,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalConstraintsFile   = mempty,+    globalRemoteRepos       = mempty,+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty,+    globalRequireSandbox    = Flag False,+    globalIgnoreSandbox     = Flag False,+    globalIgnoreExpiry      = Flag False,+    globalHttpTransport     = mempty+  }++instance Monoid GlobalFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup GlobalFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Repo context+-- ------------------------------------------------------------++-- | Access to repositories+data RepoContext = RepoContext {+    -- | All user-specified repositories+    repoContextRepos :: [Repo]++    -- | Get the HTTP transport+    --+    -- The transport will be initialized on the first call to this function.+    --+    -- NOTE: It is important that we don't eagerly initialize the transport.+    -- Initializing the transport is not free, and especially in contexts where+    -- we don't know a-priori whether or not we need the transport (for instance+    -- when using cabal in "nix mode") incurring the overhead of transport+    -- initialization on _every_ invocation (eg @cabal build@) is undesirable.+  , repoContextGetTransport :: IO HttpTransport++    -- | Get the (initialized) secure repo+    --+    -- (the 'Repo' type itself is stateless and must remain so, because it+    -- must be serializable)+  , repoContextWithSecureRepo :: forall a.+                                 Repo+                              -> (forall down. Sec.Repository down -> IO a)+                              -> IO a++    -- | Should we ignore expiry times (when checking security)?+  , repoContextIgnoreExpiry :: Bool+  }++-- | Wrapper around 'Repository', hiding the type argument+data SecureRepo = forall down. SecureRepo (Sec.Repository down)++withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a+withRepoContext verbosity globalFlags =+    withRepoContext'+      verbosity+      (fromNubList (globalRemoteRepos   globalFlags))+      (fromNubList (globalLocalRepos    globalFlags))+      (fromFlag    (globalCacheDir      globalFlags))+      (flagToMaybe (globalHttpTransport globalFlags))+      (flagToMaybe (globalIgnoreExpiry  globalFlags))++withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath]+                 -> FilePath  -> Maybe String -> Maybe Bool+                 -> (RepoContext -> IO a)+                 -> IO a+withRepoContext' verbosity remoteRepos localRepos+                 sharedCacheDir httpTransport ignoreExpiry = \callback -> do+    transportRef <- newMVar Nothing+    let httpLib = Sec.HTTP.transportAdapter+                    verbosity+                    (getTransport transportRef)+    initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->+      callback RepoContext {+          repoContextRepos          = allRemoteRepos+                                   ++ map RepoLocal localRepos+        , repoContextGetTransport   = getTransport transportRef+        , repoContextWithSecureRepo = withSecureRepo secureRepos'+        , repoContextIgnoreExpiry   = fromMaybe False ignoreExpiry+        }+  where+    secureRemoteRepos =+      [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]+    allRemoteRepos =+      [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir+      | remote <- remoteRepos+      , let cacheDir = sharedCacheDir </> remoteRepoName remote+            isSecure = remoteRepoSecure remote == Just True+      ]++    getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport+    getTransport transportRef =+      modifyMVar transportRef $ \mTransport -> do+        transport <- case mTransport of+          Just tr -> return tr+          Nothing -> configureTransport verbosity httpTransport+        return (Just transport, transport)++    withSecureRepo :: Map Repo SecureRepo+                   -> Repo+                   -> (forall down. Sec.Repository down -> IO a)+                   -> IO a+    withSecureRepo secureRepos repo callback =+      case Map.lookup repo secureRepos of+        Just (SecureRepo secureRepo) -> callback secureRepo+        Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"++-- | Initialize the provided secure repositories+--+-- Assumed invariant: `remoteRepoSecure` should be set for all these repos.+initSecureRepos :: forall a. Verbosity+                -> Sec.HTTP.HttpLib+                -> [(RemoteRepo, FilePath)]+                -> (Map Repo SecureRepo -> IO a)+                -> IO a+initSecureRepos verbosity httpLib repos callback = go Map.empty repos+  where+    go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a+    go !acc [] = callback acc+    go !acc ((r,cacheDir):rs) = do+      cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir+      initSecureRepo verbosity httpLib r cachePath $ \r' ->+        go (Map.insert (RepoSecure r cacheDir) r' acc) rs++-- | Initialize the given secure repo+--+-- The security library has its own concept of a "local" repository, distinct+-- from @cabal-install@'s; these are secure repositories, but live in the local+-- file system. We use the convention that these repositories are identified by+-- URLs of the form @file:/path/to/local/repo@.+initSecureRepo :: Verbosity+               -> Sec.HTTP.HttpLib+               -> RemoteRepo  -- ^ Secure repo ('remoteRepoSecure' assumed)+               -> Sec.Path Sec.Absolute -- ^ Cache dir+               -> (SecureRepo -> IO a)  -- ^ Callback+               -> IO a+initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do+    withRepo $ \r -> do+      requiresBootstrap <- Sec.requiresBootstrap r+      when requiresBootstrap $ Sec.uncheckClientErrors $+        Sec.bootstrap r+          (map Sec.KeyId    remoteRepoRootKeys)+          (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))+      callback $ SecureRepo r+  where+    -- Initialize local or remote repo depending on the URI+    withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a+    withRepo callback | uriScheme remoteRepoURI == "file:" = do+      dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)+      Sec.Local.withRepository dir+                               cache+                               Sec.hackageRepoLayout+                               Sec.hackageIndexLayout+                               logTUF+                               callback+    withRepo callback =+      Sec.Remote.withRepository httpLib+                                [remoteRepoURI]+                                Sec.Remote.defaultRepoOpts+                                cache+                                Sec.hackageRepoLayout+                                Sec.hackageIndexLayout+                                logTUF+                                callback++    cache :: Sec.Cache+    cache = Sec.Cache {+        cacheRoot   = cachePath+      , cacheLayout = Sec.cabalCacheLayout+      }++    -- We display any TUF progress only in verbose mode, including any transient+    -- verification errors. If verification fails, then the final exception that+    -- is thrown will of course be shown.+    logTUF :: Sec.LogMessage -> IO ()+    logTUF = info verbosity . Sec.pretty
Distribution/Client/Haddock.hs view
@@ -17,6 +17,7 @@     where  import Data.List (maximumBy)+import Data.Foldable (forM_) import System.Directory (createDirectoryIfMissing, renameFile) import System.FilePath ((</>), splitFileName) import Distribution.Package@@ -31,17 +32,16 @@ import Distribution.Simple.Utils          ( comparing, debug, installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo_(exposed) )+         ( InstalledPackageInfo(exposed) )  regenerateHaddockIndex :: Verbosity-                       -> InstalledPackageIndex -> ProgramConfiguration -> FilePath+                       -> InstalledPackageIndex -> ProgramConfiguration+                       -> FilePath                        -> IO () regenerateHaddockIndex verbosity pkgs conf index = do       (paths, warns) <- haddockPackagePaths pkgs' Nothing       let paths' = [ (interface, html) | (interface, Just html) <- paths]-      case warns of-        Nothing -> return ()-        Just m  -> debug verbosity m+      forM_ warns (debug verbosity)        (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram
Distribution/Client/HttpUtils.hs view
@@ -1,12 +1,16 @@+{-# LANGUAGE CPP, BangPatterns #-} -------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists+-- | Separate module for HTTP actions, using a proxy server if one exists. ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils (     DownloadResult(..),+    configureTransport,+    HttpTransport(..),+    HttpCode,     downloadURI,-    getHTTP,-    cabalBrowse,-    proxy,+    transportCheckHttps,+    remoteRepoCheckHttps,+    remoteRepoTryUpgradeToHttps,     isOldHackageURI   ) where @@ -15,145 +19,770 @@          , Header(..), HeaderName(..), lookupHeader ) import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI-         ( URI (..), URIAuth (..) )+         ( URI (..), URIAuth (..), uriToString ) import Network.Browser-         ( BrowserAction, browse, setAllowBasicAuth, setAuthorityGen-         , setOutHandler, setErrHandler, setProxy, request)-import Network.Stream-         ( Result, ConnError(..) )+         ( 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.Monad-         ( liftM )-import qualified Data.ByteString.Lazy.Char8 as ByteString-import Data.ByteString.Lazy (ByteString)-+         ( when, 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-         , copyFileVerbose, writeFileAtomic )+         ( die, info, warn, debug, notice, writeFileAtomic+         , copyFileVerbose,  withTempFile+         , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings )+import Distribution.Client.Utils+         ( readMaybe, withTempFileName )+import Distribution.Client.Types+         ( RemoteRepo(..) ) import Distribution.System          ( buildOS, buildArch ) import Distribution.Text          ( display )-import Data.Char ( isSpace )+import Data.Char+         ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories ) import System.FilePath          ( (<.>) ) import System.Directory-         ( doesFileExist )+         ( doesFileExist, renameFile )+import System.IO.Error+         ( isDoesNotExistError )+import Distribution.Simple.Program+         ( Program, simpleProgram, ConfiguredProgram, programPath+         , ProgramInvocation(..), programInvocation+         , getProgramInvocationOutput )+import Distribution.Simple.Program.Db+         ( ProgramDb, emptyProgramDb, addKnownPrograms+         , configureAllKnownPrograms+         , requireProgram, lookupProgram )+import Distribution.Simple.Program.Run+        ( 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(..)) -data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) --- Trim-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace---- |Get the local proxy settings---TODO: print info message when we're using a proxy based on verbosity-proxy :: Verbosity -> IO Proxy-proxy _verbosity = do-  p <- fetchProxy True-  -- Handle empty proxy strings-  return $ case p of-    Proxy uri auth ->-      let uri' = trim uri in-      if uri' == "" then NoProxy else Proxy uri' auth-    _ -> p--mkRequest :: URI-          -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header.-          -> Request ByteString-mkRequest uri etag = Request{ rqURI     = uri-                            , rqMethod  = GET-                            , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr-                            , rqBody    = ByteString.empty }-  where userAgent = concat [ "cabal-install/", display Paths_cabal_install.version-                           , " (", display buildOS, "; ", display buildArch, ")"-                           ]-        ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag---- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity-        -> URI-        -> Maybe String -- ^ Optional etag to check if we already have the latest file.-        -> IO (Result (Response ByteString))-getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $-                                   cabalBrowse verbosity Nothing (request (mkRequest uri etag))+------------------------------------------------------------------------------+-- Downloading a URI, given an HttpTransport+-- -cabalBrowse :: Verbosity-            -> Maybe (String, String)-            -> BrowserAction s a-            -> IO a-cabalBrowse verbosity auth act = do-    p   <- proxy verbosity-    browse $ do-        setProxy p-        setErrHandler (warn verbosity . ("http error: "++))-        setOutHandler (debug verbosity)-        setAllowBasicAuth False-        setAuthorityGen (\_ _ -> return auth)-        act+data DownloadResult = FileAlreadyInCache+                    | FileDownloaded FilePath+  deriving (Eq) -downloadURI :: Verbosity+downloadURI :: HttpTransport+            -> Verbosity             -> URI      -- ^ What to download             -> FilePath -- ^ Where to put it             -> IO DownloadResult-downloadURI verbosity uri path | uriScheme uri == "file:" = do+downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do   copyFileVerbose verbosity (uriPath uri) path   return (FileDownloaded path)   -- Can we store the hash of the file so we can safely return path when the   -- hash matches to avoid unnecessary computation?-downloadURI verbosity uri path = do-  let etagPath = path <.> "etag"-  targetExists   <- doesFileExist path-  etagPathExists <- doesFileExist etagPath-  -- In rare cases the target file doesn't exist, but the etag does.-  etag <- if targetExists && etagPathExists-            then liftM Just $ readFile etagPath-            else return Nothing -  result <- getHTTP verbosity uri etag-  let result' = case result of-        Left  err -> Left err-        Right rsp -> case rspCode rsp of-          (2,0,0) -> Right rsp-          (3,0,4) -> Right rsp-          (a,b,c) -> Left err-            where-              err = ErrorMisc $ "Error HTTP code: "-                                ++ concatMap show [a,b,c]+downloadURI transport verbosity uri path = do -  -- Only write the etag if we get a 200 response code.-  -- A 304 still sends us an etag header.-  case result' of-    Left _ -> return ()-    Right rsp -> case rspCode rsp of-      (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of-        Nothing -> return ()-        Just newEtag -> writeFile etagPath newEtag-      (_,_,_) -> return ()+    let etagPath = path <.> "etag"+    targetExists   <- doesFileExist path+    etagPathExists <- doesFileExist etagPath+    -- In rare cases the target file doesn't exist, but the etag does.+    etag <- if targetExists && etagPathExists+              then Just <$> readFile etagPath+              else return Nothing -  case result' of-    Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err-    Right rsp -> case rspCode rsp of-      (2,0,0) -> do-        info verbosity ("Downloaded to " ++ path)-        writeFileAtomic path $ rspBody rsp-        return (FileDownloaded path)-      (3,0,4) -> do-        notice verbosity "Skipping download: Local and remote files match."-        return FileAlreadyInCache-      (_,_,_) -> return (FileDownloaded path)-      --FIXME: check the content-length header matches the body length.-      --TODO: stream the download into the file rather than buffering the whole-      --      thing in memory.+    -- Only use the external http transports if we actually have to+    -- (or have been told to do so)+    let transport'+          | uriScheme uri == "http:"+          , not (transportManuallySelected transport)+          = plainHttpTransport --- Utility function for legacy support.+          | otherwise+          = transport++    withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do+      result <- getHttp transport' verbosity uri etag tmpFile []++      -- Only write the etag if we get a 200 response code.+      -- A 304 still sends us an etag header.+      case result of+        (200, Just newEtag) -> writeFile etagPath newEtag+        _ -> return ()++      case fst result of+        200 -> do+            info verbosity ("Downloaded to " ++ path)+            renameFile tmpFile path+            return (FileDownloaded path)+        304 -> do+            notice verbosity "Skipping download: local and remote files match."+            return FileAlreadyInCache+        errCode ->  die $ "Failed to download " ++ show uri+                       ++ " : HTTP code " ++ show errCode++------------------------------------------------------------------------------+-- Utilities for repo url management+--++remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO ()+remoteRepoCheckHttps transport repo+  | uriScheme (remoteRepoURI repo) == "https:"+  , not (transportSupportsHttps transport)+              = die $ "The remote repository '" ++ remoteRepoName repo+                   ++ "' specifies a URL that " ++ requiresHttpsErrorMessage+  | otherwise = return ()++transportCheckHttps :: HttpTransport -> URI -> IO ()+transportCheckHttps transport uri+  | uriScheme uri == "https:"+  , not (transportSupportsHttps transport)+              = die $ "The URL " ++ show uri+                   ++ " " ++ requiresHttpsErrorMessage+  | otherwise = return ()++requiresHttpsErrorMessage :: String+requiresHttpsErrorMessage =+      "requires HTTPS however the built-in HTTP implementation "+   ++ "does not support HTTPS. The transport implementations with HTTPS "+   ++ "support are " ++ intercalate ", "+      [ name | (name, _, True, _ ) <- supportedTransports ]+   ++ ". One of these will be selected automatically if the corresponding "+   ++ "external program is available, or one can be selected specifically "+   ++ "with the global flag --http-transport="++remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo+remoteRepoTryUpgradeToHttps 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 "+       ++ "HTTPS for authenticated uploads is recommended. "+       ++ "The transport implementations with HTTPS support are "+       ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]+       ++ "but they require the corresponding external program to be "+       ++ "available. You can either make one available or use plain HTTP by "+       ++ "using the global flag --http-transport=plain-http (or putting the "+       ++ "equivalent in the config file). With plain HTTP, your password "+       ++ "is sent using HTTP digest authentication so it cannot be easily "+       ++ "intercepted, but it is not as secure as using HTTPS."++  | remoteRepoShouldTryHttps repo+  , uriScheme (remoteRepoURI repo) == "http:"+  , transportSupportsHttps transport+  = return repo {+      remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }+    }++  | otherwise+  = return repo++-- | Utility function for legacy support. isOldHackageURI :: URI -> Bool isOldHackageURI uri     = case uriAuthority uri of         Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->-            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+            FilePath.Posix.splitDirectories (uriPath uri)+            == ["/","packages","archive"]         _ -> False+++------------------------------------------------------------------------------+-- Setting up a HttpTransport+--++data HttpTransport = HttpTransport {+      -- | GET a URI, with an optional ETag (to do a conditional fetch),+      -- write the resource to the given file and return the HTTP status code,+      -- and optional ETag.+      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]+               -> IO (HttpCode, Maybe ETag),++      -- | POST a resource to a URI, with optional auth (username, password)+      -- and return the HTTP status code and any redirect URL.+      postHttp :: Verbosity -> URI -> String -> Maybe Auth+               -> IO (HttpCode, String),++      -- | POST a file resource to a URI using multipart\/form-data encoding,+      -- with optional auth (username, password) and return the HTTP status+      -- code and any error string.+      postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth+                   -> IO (HttpCode, String),++      -- | PUT a file resource to a URI, with optional auth+      -- (username, password), extra headers and return the HTTP status code+      -- and any error string.+      putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]+                  -> IO (HttpCode, String),++      -- | Whether this transport supports https or just http.+      transportSupportsHttps :: Bool,++      -- | Whether this transport implementation was specifically chosen by+      -- the user via configuration, or whether it was automatically selected.+      -- Strictly speaking this is not a property of the transport itself but+      -- about how it was chosen. Nevertheless it's convenient to keep here.+      transportManuallySelected :: Bool+    }+    --TODO: why does postHttp return a redirect, but postHttpFile return errors?++type HttpCode = Int+type ETag     = String+type Auth     = (String, String)++noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)+          -> IO (Int, String)+noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet"++supportedTransports :: [(String, Maybe Program, Bool,+                         ProgramDb -> Maybe HttpTransport)]+supportedTransports =+    [ let prog = simpleProgram "curl" in+      ( "curl", Just prog, True+      , \db -> curlTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "wget" in+      ( "wget", Just prog, True+      , \db -> wgetTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "powershell" in+      ( "powershell", Just prog, True+      , \db -> powershellTransport <$> lookupProgram prog db )++    , ( "plain-http", Nothing, False+      , \_ -> Just plainHttpTransport )+    ]++configureTransport :: Verbosity -> Maybe String -> IO HttpTransport++configureTransport verbosity (Just name) =+    -- the user secifically selected a transport by name so we'll try and+    -- configure that one++    case find (\(name',_,_,_) -> name' == name) supportedTransports of+      Just (_, mprog, _tls, mkTrans) -> do++        progdb <- case mprog of+          Nothing   -> return emptyProgramDb+          Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb+                       --      ^^ if it fails, it'll fail here++        let Just transport = mkTrans progdb+        return transport { transportManuallySelected = True }++      Nothing -> die $ "Unknown HTTP transport specified: " ++ name+                    ++ ". The supported transports are "+                    ++ intercalate ", "+                         [ name' | (name', _, _, _ ) <- supportedTransports ]++configureTransport verbosity Nothing = do+    -- the user hasn't selected a transport, so we'll pick the first one we+    -- can configure successfully, provided that it supports tls++    -- for all the transports except plain-http we need to try and find+    -- their external executable+    progdb <- configureAllKnownPrograms  verbosity $+                addKnownPrograms+                  [ prog | (_, Just prog, _, _) <- supportedTransports ]+                  emptyProgramDb++    let availableTransports =+          [ (name, transport)+          | (name, _, _, mkTrans) <- supportedTransports+          , transport <- maybeToList (mkTrans progdb) ]+        -- there's always one because the plain one is last and never fails+    let (name, transport) = head availableTransports+    debug verbosity $ "Selected http transport implementation: " ++ name++    return transport { transportManuallySelected = False }+++------------------------------------------------------------------------------+-- The HttpTransports based on external programs+--++curlTransport :: ConfiguredProgram -> HttpTransport+curlTransport prog =+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+        withTempFile (takeDirectory destPath)+                     "curl-headers.txt" $ \tmpFile tmpHandle -> do+          hClose tmpHandle+          let args = [ show uri+                   , "--output", destPath+                   , "--location"+                   , "--write-out", "%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--dump-header", tmpFile ]+                ++ concat+                   [ ["--header", "If-None-Match: " ++ t]+                   | t <- maybeToList etag ]+                ++ concat+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- reqHeaders ]++          resp <- getProgramInvocationOutput verbosity+                    (programInvocation prog args)+          headers <- readFile tmpFile+          (code, _err, etag') <- parseResponse uri resp headers+          return (code, etag')++    posthttp = noPostYet++    addAuthConfig auth progInvocation = progInvocation+      { progInvokeInput = do+          (uname, passwd) <- auth+          return $ unlines+            [ "--digest"+            , "--user " ++ uname ++ ":" ++ passwd+            ]+      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation+      }++    posthttpfile verbosity uri path auth = do+        let args = [ show uri+                   , "--form", "package=@"++path+                   , "--write-out", "\n%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--header", "Accept: text/plain"+                   ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse uri resp ""+        return (code, err)++    puthttpfile verbosity uri path auth headers = do+        let args = [ show uri+                   , "--request", "PUT", "--data-binary", "@"++path+                   , "--write-out", "\n%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--header", "Accept: text/plain"+                   ]+                ++ concat+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- headers ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse uri resp ""+        return (code, err)++    -- on success these curl involcations produces an output like "200"+    -- and on failure it has the server error response first+    parseResponse uri resp headers =+      let codeerr =+            case reverse (lines resp) of+              (codeLine:rerrLines) ->+                case readMaybe (trim codeLine) of+                  Just i  -> let errstr = mkErrstr rerrLines+                              in Just (i, errstr)+                  Nothing -> Nothing+              []          -> Nothing++          mkErrstr = unlines . reverse . dropWhile (all isSpace)++          mb_etag :: Maybe ETag+          mb_etag  = listToMaybe $ reverse+                     [ etag+                     | ["ETag:", etag] <- map words (lines headers) ]++       in case codeerr of+            Just (i, err) -> return (i, err, mb_etag)+            _             -> statusParseFail uri resp+++wgetTransport :: ConfiguredProgram -> HttpTransport+wgetTransport prog =+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+        resp <- runWGet verbosity uri args+        (code, _err, etag') <- parseResponse uri resp+        return (code, etag')+      where+        args = [ "--output-document=" ++ destPath+               , "--user-agent=" ++ userAgent+               , "--tries=5"+               , "--timeout=15"+               , "--server-response" ]+            ++ concat+               [ ["--header", "If-None-Match: " ++ t]+               | t <- maybeToList etag ]+            ++ [ "--header=" ++ show name ++ ": " ++ value+               | Header name value <- reqHeaders ]++    posthttp = noPostYet++    posthttpfile verbosity  uri path auth =+        withTempFile (takeDirectory path)+                     (takeFileName path) $ \tmpFile tmpHandle -> do+          (body, boundary) <- generateMultipartBody path+          BS.hPut tmpHandle body+          BS.writeFile "wget.in" body+          hClose tmpHandle+          let args = [ "--post-file=" ++ tmpFile+                     , "--user-agent=" ++ userAgent+                     , "--server-response"+                     , "--header=Content-type: multipart/form-data; " +++                                              "boundary=" ++ boundary ]+          resp <- runWGet verbosity (addUriAuth auth uri) args+          (code, err, _etag) <- parseResponse uri resp+          return (code, err)++    puthttpfile verbosity uri path auth headers = do+        let args = [ "--method=PUT", "--body-file="++path+                   , "--user-agent=" ++ userAgent+                   , "--server-response"+                   , "--header=Accept: text/plain" ]+                ++ [ "--header=" ++ show name ++ ": " ++ value+                   | Header name value <- headers ]++        resp <- runWGet verbosity (addUriAuth auth uri) args+        (code, err, _etag) <- parseResponse uri resp+        return (code, err)++    addUriAuth Nothing uri = uri+    addUriAuth (Just (user, pass)) uri = uri+      { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }+      }+     where+      a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)++    runWGet verbosity uri args = do+        -- We pass the URI via STDIN because it contains the users' credentials+        -- and sensitive data should not be passed via command line arguments.+        let+          invocation = (programInvocation prog ("--input-file=-" : args))+            { progInvokeInput = Just (uriToString id uri "")+            }++        -- wget returns its output on stderr rather than stdout+        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity+                                 invocation+        -- wget returns exit code 8 for server "errors" like "304 not modified"+        if exitCode == ExitSuccess || exitCode == ExitFailure 8+          then return resp+          else die $ "'" ++ 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.+    --+    -- Unfortunately wget apparently cannot be persuaded to give us the body+    -- of error responses, so we just return the human readable status message+    -- like "Forbidden" etc.+    parseResponse uri resp =+      let codeerr = listToMaybe+                    [ (code, unwords err)+                    | (protocol:codestr:err) <- map words (reverse (lines resp))+                    , "HTTP/" `isPrefixOf` protocol+                    , code <- maybeToList (readMaybe codestr) ]+          mb_etag :: Maybe ETag+          mb_etag  = listToMaybe+                    [ etag+                    | ["ETag:", etag] <- map words (reverse (lines resp)) ]+       in case codeerr of+            Just (i, err) -> return (i, err, mb_etag)+            _             -> statusParseFail uri resp+++powershellTransport :: ConfiguredProgram -> HttpTransport+powershellTransport prog =+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+      resp <- runPowershellScript verbosity $+        webclientScript+          (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))+          [ "$wc.DownloadFile(" ++ escape (show uri)+              ++ "," ++ escape destPath ++ ");"+          , "Write-Host \"200\";"+          , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");"+          ]+      parseResponse resp+      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+        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]++    posthttp = noPostYet++    posthttpfile verbosity uri path auth =+      withTempFile (takeDirectory path)+                   (takeFileName path) $ \tmpFile tmpHandle -> do+        (body, boundary) <- generateMultipartBody path+        BS.hPut tmpHandle body+        hClose tmpHandle+        fullPath <- canonicalizePath tmpFile++        let contentHeader = Header HdrContentType+              ("multipart/form-data; boundary=" ++ boundary)+        resp <- runPowershellScript verbosity $ webclientScript+          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)+          (uploadFileAction "POST" uri fullPath)+        parseUploadResponse 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++    runPowershellScript verbosity script = do+      let args =+            [ "-InputFormat", "None"+            -- the default execution policy doesn't allow running+            -- unsigned scripts, so we need to tell powershell to bypass it+            , "-ExecutionPolicy", "bypass"+            , "-NoProfile", "-NonInteractive"+            , "-Command", "-"+            ]+      getProgramInvocationOutput verbosity (programInvocation prog args)+        { progInvokeInput = Just (script ++ "\nExit(0);")+        }++    escape = show++    useragentHeader = Header HdrUserAgent userAgent+    extraHeaders = [Header HdrAccept "text/plain", useragentHeader]++    setupHeaders headers =+      [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"+      | Header name value <- headers+      ]++    setupAuth auth =+      [ "$wc.Credentials = new-object System.Net.NetworkCredential("+          ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"+      | (uname,passwd) <- maybeToList auth+      ]++    uploadFileAction method uri fullPath =+      [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");"+      , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ ","+        ++ show method ++ ", $fileBytes);"+      , "Write-Host \"200\";"+      , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"+      ]++    parseUploadResponse uri resp = case lines (trim resp) of+      (codeStr : message)+        | Just code <- readMaybe codeStr -> return (code, unlines message)+      _ -> statusParseFail uri resp++    webclientScript setup action = unlines+      [ "$wc = new-object system.net.webclient;"+      , unlines setup+      , "Try {"+      , unlines (map ("  " ++) action)+      , "} Catch [System.Net.WebException] {"+      , "  $exception = $_.Exception;"+      , "  If ($exception.Status -eq "+        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"+      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"+      , "    $reader = new-object "+        ++ "System.IO.StreamReader($response.GetResponseStream());"+      , "    Write-Host ($response.StatusCode -as [int]);"+      , "    Write-Host $reader.ReadToEnd();"+      , "  } Else {"+      , "    Write-Host $exception.Message;"+      , "  }"+      , "} Catch {"+      , "  Write-Host $_.Exception.Message;"+      , "}"+      ]+++------------------------------------------------------------------------------+-- The builtin plain HttpTransport+--++plainHttpTransport :: HttpTransport+plainHttpTransport =+    HttpTransport gethttp posthttp posthttpfile puthttpfile False False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+      let req = Request{+                  rqURI     = uri,+                  rqMethod  = GET,+                  rqHeaders = [ Header HdrIfNoneMatch t+                              | t <- maybeToList etag ]+                           ++ reqHeaders,+                  rqBody    = BS.empty+                }+      (_, resp) <- cabalBrowse verbosity Nothing (request req)+      let code  = convertRspCode (rspCode resp)+          etag' = lookupHeader HdrETag (rspHeaders resp)+      when (code==200 || code==206) $+        writeFileAtomic destPath $ rspBody resp+      return (code, etag')++    posthttp = noPostYet++    posthttpfile verbosity uri path auth = do+      (body, boundary) <- generateMultipartBody path+      let headers = [ Header HdrContentType+                             ("multipart/form-data; boundary="++boundary)+                    , Header HdrContentLength (show (BS.length body))+                    , Header HdrAccept ("text/plain")+                    ]+          req = Request {+                  rqURI     = uri,+                  rqMethod  = POST,+                  rqHeaders = headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    puthttpfile verbosity uri path auth headers = do+      body <- BS.readFile path+      let req = Request {+                  rqURI     = uri,+                  rqMethod  = PUT,+                  rqHeaders = Header HdrContentLength (show (BS.length body))+                            : Header HdrAccept "text/plain"+                            : headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    convertRspCode (a,b,c) = a*100 + b*10 + c++    rspErrorString resp =+      case lookupHeader HdrContentType (rspHeaders resp) of+        Just contenttype+           | takeWhile (/= ';') contenttype == "text/plain"+          -> BS.unpack (rspBody resp)+        _ -> rspReason resp++    cabalBrowse verbosity auth act = do+      p <- fixupEmptyProxy <$> fetchProxy True+      Exception.handleJust+        (guard . isDoesNotExistError)+        (const . die $ "Couldn't establish HTTP connection. "+                    ++ "Possible cause: HTTP proxy server is down.") $+        browse $ do+          setProxy p+          setErrHandler (warn verbosity . ("http error: "++))+          setOutHandler (debug verbosity)+          setUserAgent  userAgent+          setAllowBasicAuth False+          setAuthorityGen (\_ _ -> return auth)+          act++    fixupEmptyProxy (Proxy uri _) | null uri = NoProxy+    fixupEmptyProxy p = p+++------------------------------------------------------------------------------+-- Common stuff used by multiple transport impls+--++userAgent :: String+userAgent = concat [ "cabal-install/", display Paths_cabal_install.version+                   , " (", display buildOS, "; ", display buildArch, ")"+                   ]++statusParseFail :: URI -> String -> IO a+statusParseFail uri r =+    die $ "Failed to download " ++ show uri ++ " : "+       ++ "No Status Code could be parsed from response: " ++ r++-- Trim+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace+++------------------------------------------------------------------------------+-- Multipart stuff partially taken from cgi package.+--++generateMultipartBody :: FilePath -> IO (BS.ByteString, String)+generateMultipartBody path = do+    content  <- BS.readFile path+    boundary <- genBoundary+    let !body = formatBody content (BS.pack boundary)+    return (body, boundary)+  where+    formatBody content boundary =+        BS.concat $+        [ crlf, dd, boundary, crlf ]+     ++ [ BS.pack (show header) | header <- headers ]+     ++ [ crlf+        , content+        , crlf, dd, boundary, dd, crlf ]++    headers =+      [ Header (HdrCustom "Content-disposition")+               ("form-data; name=package; " +++                "filename=\"" ++ takeFileName path ++ "\"")+      , Header HdrContentType "application/x-gzip"+      ]++    crlf = BS.pack "\r\n"+    dd   = BS.pack "--"++genBoundary :: IO String+genBoundary = do+    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+    return $ showHex i ""++------------------------------------------------------------------------------+-- Compat utils++-- TODO: This is only here temporarily so we can release without also requiring+-- the latest Cabal lib. The function is also included in Cabal now.++getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation+                                    -> IO (String, String, ExitCode)+getProgramInvocationOutputAndErrors verbosity+  ProgramInvocation {+    progInvokePath  = path,+    progInvokeArgs  = args,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = minputStr,+    progInvokeOutputEncoding = encoding+  } = do+    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False+        decode | utf8      = fromUTF8 . normaliseLineEndings+               | otherwise = id+    menv <- getEffectiveEnvironment envOverrides+    (output, errors, exitCode) <- rawSystemStdInOut verbosity+                                    path args+                                    mcwd menv+                                    input utf8+    return (decode output, decode errors, exitCode)+  where+    input =+      case minputStr of+        Nothing       -> Nothing+        Just inputStr -> Just $+          case encoding of+            IOEncodingText -> (inputStr, False)+            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
Distribution/Client/IndexUtils.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.IndexUtils@@ -14,31 +17,33 @@ module Distribution.Client.IndexUtils (   getIndexFileAge,   getInstalledPackages,+  Configure.getInstalledPackagesMonitorFiles,   getSourcePackages,-  getSourcePackagesStrict,-  convert,+  getSourcePackagesMonitorFiles, -  readPackageIndexFile,+  Index(..),+  PackageEntry(..),   parsePackageIndex,-  readRepoIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,+  readCacheStrict,    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where +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.Types  import Distribution.Package          ( PackageId, PackageIdentifier(..), PackageName(..)          , Package(..), packageVersion, packageName-         , Dependency(Dependency), InstalledPackageId(..) )+         , Dependency(Dependency) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex      as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex      as InstalledPackageIndex-import qualified Distribution.InstalledPackageInfo     as InstalledPackageInfo import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription          ( GenericPackageDescription )@@ -49,7 +54,7 @@ import Distribution.Simple.Program          ( ProgramConfiguration ) import qualified Distribution.Simple.Configure as Configure-         ( getInstalledPackages )+         ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.ParseUtils          ( ParseResult(..) ) import Distribution.Version@@ -59,16 +64,18 @@ import Distribution.Verbosity          ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8 )+         ( die, warn, info, fromUTF8, ignoreBOM )+import Distribution.Client.Setup+         ( RepoContext(..) )  import Data.Char   (isAlphaNum)-import Data.Maybe  (mapMaybe, fromMaybe)+import Data.Maybe  (mapMaybe, catMaybes, maybeToList) import Data.List   (isPrefixOf) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) #endif import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when, liftM)+import Control.Monad (when, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -79,54 +86,27 @@                                  , tryFindAddSourcePackageDesc ) import Distribution.Compat.Exception (catchIO) import Distribution.Client.Compat.Time (getFileAge, getModTime)-import System.Directory (doesFileExist)-import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.Directory (doesFileExist, doesDirectoryExist)+import System.FilePath+         ( (</>), takeExtension, replaceExtension, splitDirectories, normalise ) import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError)-import Numeric (showFFloat) +import qualified Hackage.Security.Client    as Sec+import qualified Hackage.Security.Util.Some as Sec +-- | Reduced-verbosity version of 'Configure.getInstalledPackages' getInstalledPackages :: Verbosity -> Compiler                      -> PackageDBStack -> ProgramConfiguration                      -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs conf =     Configure.getInstalledPackages verbosity' comp packageDbs conf   where-    --FIXME: make getInstalledPackages use sensible verbosity in the first place     verbosity'  = lessVerbose verbosity -convert :: InstalledPackageIndex -> PackageIndex InstalledPackage-convert index' = PackageIndex.fromList-    -- There can be multiple installed instances of each package version,-    -- like when the same package is installed in the global & user DBs.-    -- 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 (sourceDeps index' ipkg)-    | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]-  where-    -- The InstalledPackageInfo only lists dependencies by the-    -- InstalledPackageId, which means we do not directly know the corresponding-    -- source dependency. The only way to find out is to lookup the-    -- InstalledPackageId 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.-    sourceDeps index ipkg =-      [ maybe (brokenPackageId depid) packageId mdep-      | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupInstalledPackageId index-      , (depid, mdep) <- zip depids (map getpkg depids) ]--    brokenPackageId (InstalledPackageId str) =-      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])- ------------------------------------------------------------------------ -- Reading the source package index --@@ -138,31 +118,17 @@ -- 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install.----getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackages verbosity repos = getSourcePackages' verbosity repos-                                    ReadPackageIndexLazyIO---- | Like 'getSourcePackages', but reads the package index strictly. Useful if--- you want to write to the package index after having read it.-getSourcePackagesStrict :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackagesStrict verbosity repos = getSourcePackages' verbosity repos-                                          ReadPackageIndexStrict---- | Common implementation used by getSourcePackages and--- getSourcePackagesStrict.-getSourcePackages' :: Verbosity -> [Repo] -> ReadPackageIndexMode-                      -> IO SourcePackageDb-getSourcePackages' verbosity [] _mode = do+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 repos mode = do+getSourcePackages verbosity repoCtxt = do   info verbosity "Reading available packages..."-  pkgss <- mapM (\r -> readRepoIndex verbosity r mode) repos+  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -173,6 +139,13 @@     packagePreferences = prefs'   } +readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])+readCacheStrict verbosity index mkPkg = do+    updateRepoIndexCache verbosity index+    cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)+    withFile (indexFile index) ReadMode $ \indexHnd ->+      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict+ -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. --@@ -180,16 +153,13 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode+readRepoIndex :: Verbosity -> RepoContext -> Repo               -> IO (PackageIndex SourcePackage, [Dependency])-readRepoIndex verbosity repo mode =-  let indexFile = repoLocalDir repo </> "00-index.tar"-      cacheFile = repoLocalDir repo </> "00-index.cache"-  in handleNotFound $ do+readRepoIndex verbosity repoCtxt repo =+  handleNotFound $ do     warnIfIndexIsOld =<< getIndexFileAge repo-    whenCacheOutOfDate indexFile cacheFile $ do-      updatePackageIndexCacheFile verbosity indexFile cacheFile-    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode+    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)    where     mkAvailablePackage pkgEntry =@@ -208,51 +178,59 @@      handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e       then do-        case repoKind repo of-          Left  remoteRepo -> warn verbosity $-               "The package list for '" ++ remoteRepoName remoteRepo-            ++ "' does not exist. Run 'cabal update' to download it."-          Right _localRepo -> warn verbosity $-               "The package list for the local repo '" ++ repoLocalDir repo+        case repo of+          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoLocal{..}  -> warn verbosity $+               "The package list for the local repo '" ++ repoLocalDir             ++ "' is missing. The repo is invalid."         return mempty       else ioError e      isOldThreshold = 15 --days     warnIfIndexIsOld dt = do-      when (dt >= isOldThreshold) $ case repoKind repo of-        Left  remoteRepo -> warn verbosity $-             "The package list for '" ++ remoteRepoName remoteRepo-          ++ "' is " ++ showFFloat (Just 1) dt " days old.\nRun "-          ++ "'cabal update' to get the latest list of available packages."-        Right _localRepo -> return ()+      when (dt >= isOldThreshold) $ case repo of+        RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoLocal{..}  -> return () +    errMissingPackageList repoRemote =+         "The package list for '" ++ remoteRepoName repoRemote+      ++ "' does not exist. Run 'cabal update' to download it."+    errOutdatedPackageList repoRemote dt =+         "The package list for '" ++ remoteRepoName repoRemote+      ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "+      ++ "'cabal update' to get the latest list of available packages."  -- | Return the age of the index file in days (as a Double). getIndexFileAge :: Repo -> IO Double getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar" +-- | A set of files (or directories) that can be monitored to detect when+-- there might have been a change in the source packages.+--+getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]+getSourcePackagesMonitorFiles repos =+    [ repoLocalDir repo </> "00-index.cache"+    | repo <- repos ]  -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. ---updateRepoIndexCache :: Verbosity -> Repo -> IO ()-updateRepoIndexCache verbosity repo =-    whenCacheOutOfDate indexFile cacheFile $ do-      updatePackageIndexCacheFile verbosity indexFile cacheFile-  where-    indexFile = repoLocalDir repo </> "00-index.tar"-    cacheFile = repoLocalDir repo </> "00-index.cache"+updateRepoIndexCache :: Verbosity -> Index -> IO ()+updateRepoIndexCache verbosity index =+    whenCacheOutOfDate index $ do+      updatePackageIndexCacheFile verbosity index -whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO ()-whenCacheOutOfDate origFile cacheFile action = do-  exists <- doesFileExist cacheFile+whenCacheOutOfDate :: Index -> IO () -> IO ()+whenCacheOutOfDate index action = do+  exists <- doesFileExist $ cacheFile index   if not exists     then action     else do-      origTime  <- getModTime origFile-      cacheTime <- getModTime cacheFile-      when (origTime > cacheTime) action+      indexTime <- getModTime $ indexFile index+      cacheTime <- getModTime $ cacheFile index+      when (indexTime > cacheTime) action  ------------------------------------------------------------------------ -- Reading the index file@@ -279,8 +257,6 @@ typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode -type MkPackageEntry = IO PackageEntry- instance Package PackageEntry where   packageId (NormalPackage  pkgid _ _ _) = pkgid   packageId (BuildTreeRef _ pkgid _ _ _) = pkgid@@ -289,67 +265,56 @@ packageDesc (NormalPackage  _ descr _ _) = descr packageDesc (BuildTreeRef _ _ descr _ _) = descr --- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.------ This is supposed to be an \"all in one\" way to easily get at the info in--- the Hackage package index.------ It takes a function to map a 'GenericPackageDescription' into any more--- specific instance of 'Package' that you might want to use. In the simple--- case you can just use @\_ p -> p@ here.+-- | Parse an uncompressed \"00-index.tar\" repository index file represented+-- as a 'ByteString'. ---readPackageIndexFile :: Package pkg-                     => (PackageEntry -> pkg)-                     -> FilePath-                     -> IO (PackageIndex pkg, [Dependency])-readPackageIndexFile mkPkg indexFile = do-  (mkPkgs, prefs) <- either fail return-                     . parsePackageIndex-                     . maybeDecompress-                     =<< BS.readFile indexFile -  pkgEntries  <- sequence mkPkgs-  pkgs <- evaluate $ PackageIndex.fromList (map mkPkg pkgEntries)-  return (pkgs, prefs)+data PackageOrDep = Pkg PackageEntry | Dep Dependency --- | Parse an uncompressed \"00-index.tar\" repository index file represented--- as a 'ByteString'.+-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files ---parsePackageIndex :: ByteString-                  -> Either String ([MkPackageEntry], [Dependency])-parsePackageIndex = accum 0 [] [] . Tar.read+-- We read the index using 'Tar.read', which gives us a lazily constructed+-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',+-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a+-- function over this to translate it to a list of IO actions returning+-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of+-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.+parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)]+parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read   where-    accum blockNo pkgs prefs es = case es of-      Tar.Fail err   -> Left  err-      Tar.Done       -> Right (reverse pkgs, reverse prefs)-      Tar.Next e es' -> accum blockNo' pkgs' prefs' es'-        where-          (pkgs', prefs') = extract blockNo pkgs prefs e-          blockNo'        = blockNo + Tar.entrySizeInBlocks e--    extract blockNo pkgs prefs entry =-       fromMaybe (pkgs, prefs) $-                 tryExtractPkg-         `mplus` tryExtractPrefs+    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]+    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs       where         tryExtractPkg = do-          mkPkgEntry <- extractPkg entry blockNo-          return (mkPkgEntry:pkgs, prefs)+          mkPkgEntry <- maybeToList $ extractPkg entry blockNo+          return $ fmap (fmap Pkg) mkPkgEntry          tryExtractPrefs = do-          prefs' <- extractPrefs entry-          return (pkgs, prefs'++prefs)+          prefs' <- maybeToList $ extractPrefs entry+          fmap (return . Just . Dep) prefs' -extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry+-- | Turn the 'Entries' data structure from the @tar@ package into a list,+-- and pair each entry with its block number.+--+-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read+-- as far as the list is evaluated.+tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]+tarEntriesList = go 0+  where+    go !_ Tar.Done         = []+    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)+    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'++extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) extractPkg 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 (NormalPackage pkgid descr content blockNo)+          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (PackageName pkgname) ver-              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack                                                $ content               descr  = case parsed of                 ParseOk _ d -> d@@ -361,12 +326,15 @@   Tar.OtherEntryType typeCode content _     | Tar.isBuildTreeRefTypeCode typeCode ->       Just $ do-        let path   = byteStringToFilePath content-            err = "Error reading package index."-        cabalFile <- tryFindAddSourcePackageDesc path err-        descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile-        return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)-                              descr path blockNo+        let path = byteStringToFilePath content+        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+                    return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)+                                                 descr path blockNo+        return result    _ -> Nothing @@ -376,72 +344,145 @@ extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of   Tar.NormalFile content _-     | takeFileName (Tar.entryPath entry) == "preferred-versions"-    -> Just . parsePreferredVersions-     . BS.Char8.unpack $ content+     | takeFileName entrypath == "preferred-versions"+    -> Just prefs+    where+      entrypath = Tar.entryPath entry+      prefs     = parsePreferredVersions content   _ -> Nothing -parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions :: ByteString -> [Dependency] parsePreferredVersions = mapMaybe simpleParse                        . filter (not . isPrefixOf "--")                        . lines+                       . BS.Char8.unpack -- TODO: Are we sure no unicode?  ------------------------------------------------------------------------ -- Reading and updating the index cache -- -updatePackageIndexCacheFile :: Verbosity -> FilePath -> FilePath -> IO ()-updatePackageIndexCacheFile verbosity indexFile cacheFile = do-    info verbosity "Updating the index cache file..."-    (mkPkgs, prefs) <- either fail return-                       . parsePackageIndex-                       . maybeDecompress-                       =<< BS.readFile indexFile-    pkgEntries <- sequence mkPkgs-    let cache = mkCache pkgEntries prefs-    writeFile cacheFile (showIndexCache cache)+-- | Variation on 'sequence' which evaluates the actions lazily+--+-- Pattern matching on the result list will execute just the first action;+-- more generally pattern matching on the first @n@ '(:)' nodes will execute+-- the first @n@ actions.+lazySequence :: [IO a] -> IO [a]+lazySequence = unsafeInterleaveIO . go   where-    mkCache pkgs prefs =-        [ CachePreference pref          | pref <- prefs ]-     ++ [ CachePackageId pkgid blockNo-        | (NormalPackage pkgid _ _ blockNo) <- pkgs ]-     ++ [ CacheBuildTreeRef refType blockNo-        | (BuildTreeRef refType _ _ _ blockNo) <- pkgs]+    go []     = return []+    go (x:xs) = do x'  <- x+                   xs' <- lazySequence xs+                   return (x' : xs') +-- | Which index do we mean?+data Index =+    -- | The main index for the specified repository+    RepoIndex RepoContext Repo++    -- | A sandbox-local repository+    -- Argument is the location of the index file+  | SandboxIndex FilePath++indexFile :: Index -> FilePath+indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"+indexFile (SandboxIndex index)   = index++cacheFile :: Index -> FilePath+cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"+cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"++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)++-- | Read the index (for the purpose of building a cache)+--+-- The callback is provided with list of cache entries, which is guaranteed to+-- be lazily constructed. This list must ONLY be used in the scope of the+-- callback; when the callback is terminated the file handle to the index will+-- be closed and further attempts to read from the list will result in (pure)+-- I/O exceptions.+--+-- In the construction of the index for a secure repo we take advantage of the+-- index built by the @hackage-security@ library to avoid reading the @.tar@+-- file as much as possible (we need to read it only to extract preferred+-- versions). This helps performance, but is also required for correctness:+-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions+-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);+-- by reading the already-built cache from the security library we will be sure+-- to only read the latest versions of all files.+--+-- TODO: It would be nicer if we actually incrementally updated @cabal@'s+-- cache, rather than reconstruct it from zero on each update. However, this+-- would require a change in the cache format.+withIndexEntries :: 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+    withFile (indexFile index) ReadMode $ \h -> do+      bs          <- maybeDecompress `fmap` BS.hGetContents h+      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs+      callback $ map toCache (catMaybes pkgsOrPrefs)+  where+    toCache :: PackageOrDep -> IndexCacheEntry+    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo+    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo+    toCache (Dep d) = CachePreference d+ data ReadPackageIndexMode = ReadPackageIndexStrict                           | ReadPackageIndexLazyIO  readPackageIndexCacheFile :: Package pkg                           => (PackageEntry -> pkg)-                          -> FilePath-                          -> FilePath-                          -> ReadPackageIndexMode+                          -> Index                           -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do-  cache    <- liftM readIndexCache (BSS.readFile cacheFile)-  myWithFile indexFile ReadMode $ \indexHnd ->-    packageIndexFromCache mkPkg indexHnd cache mode-  where-    myWithFile f m act = case mode of-      ReadPackageIndexStrict -> withFile f m act-      ReadPackageIndexLazyIO -> do indexHnd <- openFile f m-                                   act indexHnd-+readPackageIndexCacheFile mkPkg index = do+  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)+  indexHnd <- openFile (indexFile index) ReadMode+  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO  packageIndexFromCache :: Package pkg                       => (PackageEntry -> pkg)                       -> Handle-                      -> [IndexCacheEntry]+                      -> Cache                       -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs+packageIndexFromCache mkPkg hnd cache mode = do+     (pkgs, prefs) <- packageListFromCache 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)+                     -> Handle+                     -> Cache+                     -> ReadPackageIndexMode+                     -> IO ([pkg], [Dependency])+packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries   where-    accum srcpkgs prefs [] = do-      -- Have to reverse entries, since in a tar file, later entries mask-      -- earlier ones, and PackageIndex.fromList does the same, but we-      -- accumulate the list of entries in reverse order, so need to reverse.-      pkgIndex <- evaluate $ PackageIndex.fromList (reverse srcpkgs)-      return (pkgIndex, prefs)+    accum srcpkgs prefs [] = return (reverse srcpkgs, prefs)      accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do       -- Given the cache entry, make a package index entry.@@ -476,26 +517,17 @@      getEntryContent :: BlockNo -> IO ByteString     getEntryContent blockno = do-      hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))-      header  <- BS.hGet hnd 512-      size    <- getEntrySize header-      BS.hGet hnd (fromIntegral size)--    getEntrySize :: ByteString -> IO Tar.FileSize-    getEntrySize header =-      case Tar.read header of-        Tar.Next e _ ->-          case Tar.entryContent e of-            Tar.NormalFile _ size -> return size-            Tar.OtherEntryType typecode _ size-              | Tar.isBuildTreeRefTypeCode typecode-                                  -> return size-            _                     -> interror "unexpected tar entry type"-        _ -> interror "could not read tar file entry"+      entry <- Tar.hReadEntry hnd blockno+      case Tar.entryContent entry of+        Tar.NormalFile content _size -> return content+        Tar.OtherEntryType typecode content _size+          | Tar.isBuildTreeRefTypeCode typecode+          -> return content+        _ -> interror "unexpected tar entry type"      readPackageDescription :: ByteString -> IO GenericPackageDescription     readPackageDescription content =-      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ d -> return d         _           -> interror "failed to parse .cabal file" @@ -510,15 +542,15 @@ -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. ---type BlockNo = Int+type BlockNo = Tar.TarEntryOffset  data IndexCacheEntry = CachePackageId PackageId BlockNo                      | CacheBuildTreeRef BuildTreeRefType BlockNo                      | CachePreference Dependency   deriving (Eq) -packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String-packageKey = "pkg:"+installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+installedUnitId = "pkg:" blocknoKey = "b#" buildTreeRefKey     = "build-tree-ref:" preferredVersionKey = "pref-ver:"@@ -527,7 +559,7 @@ readIndexCacheEntry = \line ->   case BSS.words line of     [key, pkgnamestr, pkgverstr, sep, blocknostr]-      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->+      | key == BSS.pack installedUnitId && sep == BSS.pack blocknoKey ->       case (parseName pkgnamestr, parseVer pkgverstr [],             parseBlockNo blocknostr) of         (Just pkgname, Just pkgver, Just blockno)@@ -558,8 +590,9 @@      parseBlockNo str =       case BSS.readInt str of-        Just (blockno, remainder) | BSS.null remainder -> Just blockno-        _                                              -> Nothing+        Just (blockno, remainder)+          | BSS.null remainder -> Just (fromIntegral blockno)+        _                      -> Nothing      parseRefType str =       case BSS.uncons str of@@ -570,7 +603,7 @@  showIndexCacheEntry :: IndexCacheEntry -> String showIndexCacheEntry entry = unwords $ case entry of-   CachePackageId pkgid b -> [ packageKey+   CachePackageId pkgid b -> [ installedUnitId                              , display (packageName pkgid)                              , display (packageVersion pkgid)                              , blocknoKey@@ -584,8 +617,15 @@                              , display dep                              ] -readIndexCache :: BSS.ByteString -> [IndexCacheEntry]-readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines+-- | Cabal caches various information about the Hackage index+data Cache = Cache {+    cacheEntries :: [IndexCacheEntry]+  } -showIndexCache :: [IndexCacheEntry] -> String-showIndexCache = unlines . map showIndexCacheEntry+readIndexCache :: BSS.ByteString -> Cache+readIndexCache bs = Cache {+    cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs+  }++showIndexCache :: Cache -> String+showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries
Distribution/Client/Init.hs view
@@ -18,6 +18,8 @@      -- * Commands     initCabal+  , pvpize+  , incVersion    ) where @@ -41,10 +43,10 @@   ( on ) import qualified Data.Map as M #if !MIN_VERSION_base(4,8,0)-import Data.Traversable-  ( traverse ) import Control.Applicative   ( (<$>) )+import Data.Traversable+  ( traverse ) #endif import Control.Monad   ( when, unless, (>=>), join, forM_ )@@ -93,23 +95,38 @@ import Distribution.Text   ( display, Text(..) ) +import Distribution.Client.PackageIndex+  ( elemByPackageName )+import Distribution.Client.IndexUtils+  ( getSourcePackages )+import Distribution.Client.Types+  ( SourcePackageDb(..) )+import Distribution.Client.Setup+  ( RepoContext(..) )+ initCabal :: Verbosity           -> PackageDBStack+          -> RepoContext           -> Compiler           -> ProgramConfiguration           -> InitFlags           -> IO ()-initCabal verbosity packageDBs comp conf initFlags = do+initCabal verbosity packageDBs repoCtxt comp conf initFlags = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  sourcePkgDb <- getSourcePackages verbosity repoCtxt    hSetBuffering stdout NoBuffering -  initFlags' <- extendFlags installedPkgIndex initFlags+  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags -  writeLicense initFlags'+  case license initFlags' of+    Flag PublicDomain -> return ()+    _                 -> writeLicense initFlags'   writeSetupFile initFlags'+  writeChangeLog initFlags'   createSourceDirectories initFlags'+  createMainHs initFlags'   success <- writeCabalFile initFlags'    when success $ generateWarnings initFlags'@@ -120,9 +137,9 @@  -- | Fill in more details by guessing, discovering, or prompting the --   user.-extendFlags :: InstalledPackageIndex -> InitFlags -> IO InitFlags-extendFlags pkgIx =-      getPackageName+extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags+extendFlags pkgIx sourcePkgDb =+      getPackageName sourcePkgDb   >=> getVersion   >=> getLicense   >=> getAuthorInfo@@ -131,9 +148,9 @@   >=> getCategory   >=> getExtraSourceFiles   >=> getLibOrExec+  >=> getSrcDir   >=> getLanguage   >=> getGenComments-  >=> getSrcDir   >=> getModulesBuildToolsAndDeps pkgIx  -- | Combine two actions which may return a value, preferring the first. That@@ -151,18 +168,36 @@ maybeToFlag = maybe NoFlag Flag  -- | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess.-getPackageName :: InitFlags -> IO InitFlags-getPackageName flags = do+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags+getPackageName sourcePkgDb flags = do   guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)               ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) +  let guess' | isPkgRegistered guess = Nothing+             | otherwise = guess+   pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (prompt "Package name" guess)-              ?>> return guess+              ?>> maybePrompt flags (prompt "Package name" guess')+              ?>> return guess' -  return $ flags { packageName = maybeToFlag pkgName' }+  chooseAgain <- if isPkgRegistered pkgName'+                    then promptYesNo promptOtherNameMsg (Just True)+                    else return False +  if chooseAgain+    then getPackageName sourcePkgDb flags+    else return $ flags { packageName = maybeToFlag pkgName' }++  where+    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg+    isPkgRegistered Nothing    = False++    promptOtherNameMsg = "This package name is already used by another " +++                         "package on hackage. Do you want to choose a " +++                         "different name"+ -- | Package version: use 0.1.0.0 as a last resort, but try prompting the user --  if possible. getVersion :: InitFlags -> IO InitFlags@@ -177,9 +212,9 @@ getLicense :: InitFlags -> IO InitFlags getLicense flags = do   lic <-     return (flagToMaybe $ license flags)-         ?>> fmap (fmap (either UnknownLicense id) . join)+         ?>> fmap (fmap (either UnknownLicense id))                   (maybePrompt flags-                    (promptListOptional "Please choose a license" listedLicenses))+                    (promptList "Please choose a license" listedLicenses (Just BSD3) display True))   return $ flags { license = maybeToFlag lic }   where     listedLicenses =@@ -245,6 +280,9 @@    return $ flags { extraSrc = extraSrcFiles } +defaultChangeLog :: FilePath+defaultChangeLog = "ChangeLog.md"+ -- | Try to guess things to include in the extra-source-files field. --   For now, we just look for things in the root directory named --   'readme', 'changes', or 'changelog', with any sort of@@ -254,12 +292,16 @@   dir <-     maybe getCurrentDirectory return . flagToMaybe $ packageDir flags   files <- getDirectoryContents dir-  return $ filter isExtra files+  let extraFiles = filter isExtra files+  if any isLikeChangeLog extraFiles+    then return extraFiles+    else return (defaultChangeLog : extraFiles)    where-    isExtra = (`elem` ["README", "CHANGES", "CHANGELOG"])-            . map toUpper-            . takeBaseName+    isExtra = likeFileNameBase ("README" : changeLogLikeBases)+    isLikeChangeLog = likeFileNameBase changeLogLikeBases+    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName+    changeLogLikeBases = ["CHANGES", "CHANGELOG"]  -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags@@ -285,7 +327,7 @@   return (flagToMaybe $ mainIs flags)   ?>> do     candidates <- guessMainFileCandidates flags-    let showCandidate = either (++" (does not yet exist)") id+    let showCandidate = either (++" (does not yet exist, but will be created)") id         defaultFile = listToMaybe candidates     maybePrompt flags (either id (either id id) `fmap`                        promptList "What is the main module of the executable"@@ -314,14 +356,14 @@                  ?>> return (Just False)   return $ flags { noComments = maybeToFlag (fmap not genComments) }   where-    promptMsg = "Include documentation on what each field means (y/n)"+    promptMsg = "Add informative comments to each field in the cabal file (y/n)"  -- | Ask for the source root directory. getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do   srcDirs <- return (sourceDirs flags)              ?>> fmap (:[]) `fmap` guessSourceDir flags-             ?>> fmap (fmap ((:[]) . either id id) . join) (maybePrompt+             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt                       flags                       (promptListOptional' "Source directory" ["src"] id)) @@ -343,7 +385,7 @@ getModulesBuildToolsAndDeps pkgIx flags = do   dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags -  -- XXX really should use guessed source roots.+  -- TODO: really should use guessed source roots.   sourceFiles <- scanForModules dir    Just mods <-      return (exposedModules flags)@@ -427,12 +469,17 @@       return $ P.Dependency (P.pkgName . head $ pids)                             (pvpize . maximum . map P.pkgVersion $ pids) -    pvpize :: Version -> VersionRange-    pvpize v = orLaterVersion v'-               `intersectVersionRanges`-               earlierVersion (incVersion 1 v')-      where v' = (v { versionBranch = take 2 (versionBranch v) })+-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- Example: @0.4.1@ produces the version range @>= 0.4 && < 0.5@ (which is the+-- same as @0.4.*@).+pvpize :: Version -> VersionRange+pvpize v = orLaterVersion v'+           `intersectVersionRanges`+           earlierVersion (incVersion 1 v')+  where v' = (v { versionBranch = take 2 (versionBranch v) }) +-- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags   where@@ -629,6 +676,23 @@     , "main = defaultMain"     ] +writeChangeLog :: InitFlags -> IO ()+writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do+  message flags ("Generating "++ defaultChangeLog ++"...")+  writeFileSafe flags defaultChangeLog changeLog+ where+  changeLog = unlines+    [ "# Revision history for " ++ pname+    , ""+    , "## " ++ pver ++ "  -- YYYY-mm-dd"+    , ""+    , "* First version. Released on an unsuspecting world."+    ]+  pname = maybe "" display $ flagToMaybe $ packageName flags+  pver = maybe "" display $ flagToMaybe $ version flags+++ writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do   message flags "Error: no package name provided."@@ -652,6 +716,38 @@                                   Just dirs -> forM_ dirs (createDirectoryIfMissing True)                                   Nothing   -> return () +-- | Create Main.hs, but only if we are init'ing an executable and+--   the mainIs flag has been provided.+createMainHs :: InitFlags -> IO ()+createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_)+                            , packageType = Flag Executable+                            , mainIs = Flag mainFile } =+  writeMainHs flags (srcPath </> mainFile)+createMainHs flags@InitFlags{ sourceDirs = _+                            , packageType = Flag Executable+                            , mainIs = Flag mainFile } =+  writeMainHs flags mainFile+createMainHs _ = return ()++-- | Write a main file if it doesn't already exist.+writeMainHs :: InitFlags -> FilePath -> IO ()+writeMainHs flags mainPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let mainFullPath = dir </> mainPath+  exists <- doesFileExist mainFullPath+  unless exists $ do+      message flags $ "Generating " ++ mainPath ++ "..."+      writeFileSafe flags mainFullPath mainHs++-- | Default Main.hs file.  Used when no Main.hs exists.+mainHs :: String+mainHs = unlines+  [ "module Main where"+  , ""+  , "main :: IO ()"+  , "main = putStrLn \"Hello, Haskell!\""+  ]+ -- | Move an existing file, if there is one, and the overwrite flag is --   not set. moveExistingFile :: InitFlags -> FilePath -> IO ()@@ -682,6 +778,7 @@ --   pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c =+  (++ "\n") .   renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $   (if minimal c /= Flag True     then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "@@ -695,7 +792,7 @@                 True         , field  "version"       (version       c)-                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttp://www.haskell.org/haskellwiki/Package_versioning_policy\n"+                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://wiki.haskell.org/Package_versioning_policy\n"                 ++ "PVP summary:      +-+------- breaking API changes\n"                 ++ "                  | | +----- non-breaking API additions\n"                 ++ "                  | | | +--- code changes with no API change")@@ -721,9 +818,11 @@                 (Just "The license under which the package is released.")                 True -       , fieldS "license-file" (Flag "LICENSE")-                (Just "The file containing the license text.")-                True+       , case (license c) of+           Flag PublicDomain -> empty+           _ -> fieldS "license-file" (Flag "LICENSE")+                       (Just "The file containing the license text.")+                       True         , fieldS "author"        (author       c)                 (Just "The package author(s).")@@ -733,9 +832,11 @@                 (Just "An email address to which users can send suggestions, bug reports, and patches.")                 True -       , fieldS "copyright"     NoFlag-                (Just "A copyright notice.")-                True+       , case (license c) of+           Flag PublicDomain -> empty+           _ -> fieldS "copyright"     NoFlag+                       (Just "A copyright notice.")+                       True         , fieldS "category"      (either id display `fmap` category c)                 Nothing
Distribution/Client/Init/Heuristics.hs view
@@ -38,6 +38,7 @@ 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 )@@ -45,9 +46,6 @@ import Data.Either ( partitionEithers ) import Data.List   ( isInfixOf, isPrefixOf, isSuffixOf, sortBy ) import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid ( mempty, mappend, mconcat, )-#endif import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList ) import System.Directory ( getCurrentDirectory, getDirectoryContents,@@ -177,7 +175,7 @@               . lines               $ s -      -- XXX we should probably make a better attempt at parsing+      -- TODO: We should probably make a better attempt at parsing       -- comments above.  Unfortunately we can't use a full-fledged       -- Haskell parser since cabal's dependencies must be kept at a       -- minimum.@@ -327,12 +325,19 @@ maybeFlag :: String -> Enviro -> Flag String maybeFlag k = maybe mempty Flag . lookup k +-- | Read the first non-comment, non-trivial line of a file, if it exists maybeReadFile :: String -> IO (Maybe String) maybeReadFile f = do     exists <- doesFileExist f     if exists-        then fmap Just $ readFile f+        then fmap getFirstLine $ readFile f         else return Nothing+  where+    getFirstLine content =+      let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content+      in case nontrivialLines of+           [] -> Nothing+           (l:_) -> Just l  -- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String]
Distribution/Client/Init/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Types@@ -17,6 +18,7 @@ import Distribution.Simple.Setup   ( Flag(..) ) +import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity import qualified Distribution.Package as P@@ -28,9 +30,7 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Text -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif+import GHC.Generics ( Generic )  -- | InitFlags is really just a simple type to represent certain --   portions of a .cabal file.  Rather than have a flag for EVERY@@ -71,7 +71,7 @@               , initVerbosity :: Flag Verbosity               , overwrite     :: Flag Bool               }-  deriving (Show)+  deriving (Show, Generic)    -- the Monoid instance for Flag has later values override earlier   -- ones, which is why we want Maybe [foo] for collecting foo values,@@ -85,63 +85,11 @@   parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]  instance Monoid InitFlags where-  mempty = InitFlags-    { nonInteractive = mempty-    , quiet          = mempty-    , packageDir     = mempty-    , noComments     = mempty-    , minimal        = mempty-    , packageName    = mempty-    , version        = mempty-    , cabalVersion   = mempty-    , license        = mempty-    , author         = mempty-    , email          = mempty-    , homepage       = mempty-    , synopsis       = mempty-    , category       = mempty-    , extraSrc       = mempty-    , packageType    = mempty-    , mainIs         = mempty-    , language       = mempty-    , exposedModules = mempty-    , otherModules   = mempty-    , otherExts      = mempty-    , dependencies   = mempty-    , sourceDirs     = mempty-    , buildTools     = mempty-    , initVerbosity  = mempty-    , overwrite      = mempty-    }-  mappend  a b = InitFlags-    { nonInteractive = combine nonInteractive-    , quiet          = combine quiet-    , packageDir     = combine packageDir-    , noComments     = combine noComments-    , minimal        = combine minimal-    , packageName    = combine packageName-    , version        = combine version-    , cabalVersion   = combine cabalVersion-    , license        = combine license-    , author         = combine author-    , email          = combine email-    , homepage       = combine homepage-    , synopsis       = combine synopsis-    , category       = combine category-    , extraSrc       = combine extraSrc-    , packageType    = combine packageType-    , mainIs         = combine mainIs-    , language       = combine language-    , exposedModules = combine exposedModules-    , otherModules   = combine otherModules-    , otherExts      = combine otherExts-    , dependencies   = combine dependencies-    , sourceDirs     = combine sourceDirs-    , buildTools     = combine buildTools-    , initVerbosity  = combine initVerbosity-    , overwrite      = combine overwrite-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>)++instance Semigroup InitFlags where+  (<>) = gmappend  -- | Some common package categories. data Category
Distribution/Client/Install.hs view
@@ -29,12 +29,14 @@     pruneInstallPlan   ) where +import Data.Foldable+         ( traverse_ ) import Data.List          ( isPrefixOf, unfoldr, nub, sort, (\\) ) import qualified Data.Map as Map import qualified Data.Set as S import Data.Maybe-         ( isJust, fromMaybe, mapMaybe, maybeToList )+         ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe ) import Control.Exception as Exception          ( Exception(toException), bracket, catches          , Handler(Handler), handleJust, IOException, SomeException )@@ -49,9 +51,11 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative          ( (<$>) )+import Data.Traversable+         ( traverse ) #endif import Control.Monad-         ( forM_, when, unless )+         ( filterM, forM_, when, unless ) import System.Directory          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,            createDirectoryIfMissing, removeFile, renameDirectory )@@ -64,18 +68,20 @@  import Distribution.Client.Targets import Distribution.Client.Configure-         ( chooseCabalVersion )+         ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types-         ( Solver(..) )+         ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.FetchUtils+import Distribution.Client.HttpUtils+         ( HttpTransport (..) ) import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup-         ( GlobalFlags(..)+         ( GlobalFlags(..), RepoContext(..)          , ConfigFlags(..), configureCommand, filterConfigureFlags          , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config@@ -102,6 +108,7 @@ import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl+import qualified Distribution.Client.ComponentDeps as CD  import Distribution.Utils.NubList import Distribution.Simple.Compiler@@ -112,9 +119,12 @@ 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(..)          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal          ( Flag(..)@@ -129,14 +139,18 @@          , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package          ( PackageIdentifier(..), PackageId, packageName, packageVersion-         , Package(..), PackageFixedDeps(..), PackageKey-         , Dependency(..), thisPackageVersion, InstalledPackageId, installedPackageId )+         , Package(..)+         , Dependency(..), thisPackageVersion+         , UnitId(..), mkUnitId+         , HasUnitId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)          , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePackageDescription )+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.ParseUtils          ( showPWarning ) import Distribution.Version@@ -145,7 +159,7 @@          ( notice, info, warn, debug, debugNoWrap, die          , intercalate, withTempDirectory ) import Distribution.Client.Utils-         ( determineNumJobs, inDir, mergeBy, MergeResult(..)+         ( determineNumJobs, inDir, logDirChange, mergeBy, MergeResult(..)          , tryCanonicalizePath ) import Distribution.System          ( Platform, OS(Windows), buildOS )@@ -176,7 +190,7 @@ install   :: Verbosity   -> PackageDBStack-  -> [Repo]+  -> RepoContext   -> Compiler   -> Platform   -> ProgramConfiguration@@ -222,13 +236,15 @@ -- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( InstalledPackageIndex, SourcePackageDb-                      , [UserTarget], [PackageSpecifier SourcePackage] )+                      , PkgConfigDb+                      , [UserTarget], [PackageSpecifier SourcePackage]+                      , HttpTransport )  -- TODO: Make InstallArgs a proper data type with documented fields or just get -- rid of it completely. -- | Initial arguments given to 'install' or 'makeInstallContext'. type InstallArgs = ( PackageDBStack-                   , [Repo]+                   , RepoContext                    , Compiler                    , Platform                    , ProgramConfiguration@@ -244,12 +260,17 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]                       -> IO InstallContext makeInstallContext verbosity-  (packageDBs, repos, comp, _, conf,_,_,-   globalFlags, _, _, _, _) mUserTargets = do+  (packageDBs, repoCtxt, comp, _, conf,_,_,+   globalFlags, _, configExFlags, _, _) mUserTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf +    checkConfigExFlags verbosity installedPkgIndex+                       (packageIndex sourcePkgDb) configExFlags+    transport <- repoContextGetTransport repoCtxt+     (userTargets, pkgSpecifiers) <- case mUserTargets of       Nothing           ->         -- We want to distinguish between the case where the user has given an@@ -262,13 +283,14 @@         let userTargets | null userTargets0 = [UserTargetLocalDir "."]                         | otherwise         = userTargets0 -        pkgSpecifiers <- resolveUserTargets verbosity+        pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                          (fromFlag $ globalWorldFile globalFlags)                          (packageIndex sourcePkgDb)                          userTargets         return (userTargets, pkgSpecifiers) -    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)+    return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets+           ,pkgSpecifiers, transport)  -- | Make an install plan given install context and install arguments. makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext@@ -277,25 +299,25 @@   (_, _, comp, platform, _, _, mSandboxPkgInfo,    _, configFlags, configExFlags, installFlags,    _)-  (installedPkgIndex, sourcePkgDb,-   _, pkgSpecifiers) = do+  (installedPkgIndex, sourcePkgDb, pkgConfigDb,+   _, pkgSpecifiers, _) = do      solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))               (compilerInfo comp)     notice verbosity "Resolving dependencies..."     return $ planPackages comp platform mSandboxPkgInfo solver       configFlags configExFlags installFlags-      installedPkgIndex sourcePkgDb pkgSpecifiers+      installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers  -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext                    -> InstallPlan                    -> IO () processInstallPlan verbosity-  args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _)-  (installedPkgIndex, sourcePkgDb,-   userTargets, pkgSpecifiers) installPlan = do-    checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb+  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)+  (installedPkgIndex, sourcePkgDb, _,+   userTargets, pkgSpecifiers, _) installPlan = do+    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers      unless (dryRun || nothingToInstall) $ do@@ -319,14 +341,15 @@              -> InstallFlags              -> InstalledPackageIndex              -> SourcePackageDb+             -> PkgConfigDb              -> [PackageSpecifier SourcePackage]              -> Progress String String InstallPlan planPackages comp platform mSandboxPkgInfo solver              configFlags configExFlags installFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers =+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =          resolveDependencies-          platform (compilerInfo comp)+          platform (compilerInfo comp) pkgConfigDb           solver           resolverParams @@ -360,18 +383,23 @@        . addConstraints           -- version constraints from the config file or command line-            (map userToPackageConstraint (configExConstraints configExFlags))+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- configExConstraints configExFlags ]        . addConstraints           --FIXME: this just applies all flags to all targets which           -- is silly. We should check if the flags are appropriate-          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags+          [ let pc = PackageConstraintFlags+                     (pkgSpecifierTarget pkgSpecifier) flags+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | let flags = configConfigurationsFlags configFlags           , not (null flags)           , pkgSpecifier <- pkgSpecifiers ]        . addConstraints-          [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas+          [ let pc = PackageConstraintStanzas+                     (pkgSpecifierTarget pkgSpecifier) stanzas+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | pkgSpecifier <- pkgSpecifiers ]        . maybe id applySandboxInstallPolicy mSandboxPkgInfo@@ -381,27 +409,28 @@       $ standardInstallPolicy         installedPkgIndex sourcePkgDb pkgSpecifiers -    stanzas = concat-        [ if testsEnabled then [TestStanzas] else []-        , if benchmarksEnabled then [BenchStanzas] else []-        ]-    testsEnabled = fromFlagOrDefault False $ configTests configFlags+    stanzas           = [ TestStanzas | testsEnabled ]+                     ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ configTests configFlags     benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags -    reinstall        = fromFlag (installReinstall        installFlags)-    reorderGoals     = fromFlag (installReorderGoals     installFlags)-    independentGoals = fromFlag (installIndependentGoals installFlags)-    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)-    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)-    strongFlags      = fromFlag (installStrongFlags      installFlags)-    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)-    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)-    onlyDeps         = fromFlag (installOnlyDeps         installFlags)-    allowNewer       = fromFlag (configAllowNewer        configExFlags)+    reinstall        = fromFlag (installOverrideReinstall installFlags) ||+                       fromFlag (installReinstall         installFlags)+    reorderGoals     = fromFlag (installReorderGoals      installFlags)+    independentGoals = fromFlag (installIndependentGoals  installFlags)+    avoidReinstalls  = fromFlag (installAvoidReinstalls   installFlags)+    shadowPkgs       = fromFlag (installShadowPkgs        installFlags)+    strongFlags      = fromFlag (installStrongFlags       installFlags)+    maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)+    upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)+    onlyDeps         = fromFlag (installOnlyDeps          installFlags)+    allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)  -- | Remove the provided targets from the install plan.-pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan-                    -> Progress String String InstallPlan+pruneInstallPlan :: Package targetpkg+                 => [PackageSpecifier targetpkg]+                 -> InstallPlan+                 -> Progress String String InstallPlan 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@@ -409,7 +438,7 @@   either (Fail . explain) Done   . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)   where-    explain :: [InstallPlan.PlanProblem] -> String+    explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String     explain problems =       "Cannot select only the dependencies (as requested by the "       ++ "'--only-dependencies' flag), "@@ -434,14 +463,13 @@ -- | Perform post-solver checks of the install plan and print it if -- either requested or needed. checkPrintPlan :: Verbosity-               -> Compiler                -> InstalledPackageIndex                -> InstallPlan                -> SourcePackageDb                -> InstallFlags                -> [PackageSpecifier SourcePackage]                -> IO ()-checkPrintPlan verbosity comp installed installPlan sourcePkgDb+checkPrintPlan verbosity installed installPlan sourcePkgDb   installFlags pkgSpecifiers = do    -- User targets that are already installed.@@ -458,21 +486,21 @@        : map (display . packageId) preExistingTargets       ++ ["Use --reinstall if you want to reinstall anyway."] -  let lPlan = linearizeInstallPlan comp installed installPlan+  let lPlan = linearizeInstallPlan installed installPlan   -- Are any packages classified as reinstalls?   let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan   -- Packages that are already broken.   let oldBrokenPkgs =-          map Installed.installedPackageId+          map Installed.installedUnitId         . PackageIndex.reverseDependencyClosure installed-        . map (Installed.installedPackageId . fst)+        . map (Installed.installedUnitId . fst)         . PackageIndex.brokenPackages         $ installed   let excluded = reinstalledPkgs ++ oldBrokenPkgs   -- Packages that are reverse dependencies of replaced packages are very   -- likely to be broken. We exclude packages that are already broken.   let newBrokenPkgs =-        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))+        filter (\ p -> not (Installed.installedUnitId p `elem` excluded))                (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)   let containsReinstalls = not (null reinstalledPkgs)   let breaksPkgs         = not (null newBrokenPkgs)@@ -498,36 +526,54 @@           : map (display . Installed.sourcePackageId) newBrokenPkgs           ++ if overrideReinstall                then if dryRun then [] else-                 ["Continuing even though the plan contains dangerous reinstalls."]+                 ["Continuing even though " +++                  "the plan contains dangerous reinstalls."]                else                  ["Use --force-reinstalls if you want to install anyway."]       else unless dryRun $ warn verbosity              "Note that reinstalls are always dangerous. Continuing anyway..." +  -- If we are explicitly told to not download anything, check that all packages+  -- are already fetched.+  let offline = fromFlagOrDefault False (installOfflineMode installFlags)+  when offline $ do+    let pkgs = [ sourcePkg+               | InstallPlan.Configured (ConfiguredPackage sourcePkg _ _ _)+                 <- InstallPlan.toList installPlan ]+    notFetched <- fmap (map packageInfoId)+                  . filterM (fmap isNothing . checkFetched . packageSource)+                  $ pkgs+    unless (null notFetched) $+      die $ "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)      dryRun            = fromFlag (installDryRun            installFlags)     overrideReinstall = fromFlag (installOverrideReinstall installFlags) -linearizeInstallPlan :: Compiler-                     -> InstalledPackageIndex+--TODO: this type is too specific+linearizeInstallPlan :: InstalledPackageIndex                      -> InstallPlan                      -> [(ReadyPackage, PackageStatus)]-linearizeInstallPlan comp installedPkgIndex plan =+linearizeInstallPlan installedPkgIndex plan =     unfoldr next plan   where     next plan' = case InstallPlan.ready plan' of       []      -> Nothing       (pkg:_) -> Just ((pkg, status), plan'')         where-          pkgid  = installedPackageId pkg-          status = packageStatus comp installedPkgIndex pkg-          plan'' = InstallPlan.completed pkgid-                     (BuildOk DocsNotTried TestsNotTried-                              (Just $ Installed.emptyInstalledPackageInfo-                              { Installed.sourcePackageId = packageId pkg-                              , Installed.installedPackageId = pkgid }))+          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@@ -536,23 +582,25 @@  data PackageStatus = NewPackage                    | NewVersion [Version]-                   | Reinstall  [InstalledPackageId] [PackageChange]+                   | Reinstall  [UnitId] [PackageChange]  type PackageChange = MergeResult PackageIdentifier PackageIdentifier -extractReinstalls :: PackageStatus -> [InstalledPackageId]+extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = [] -packageStatus :: Compiler -> InstalledPackageIndex -> ReadyPackage -> PackageStatus-packageStatus _comp installedPkgIndex cpkg =+packageStatus :: InstalledPackageIndex+              -> ReadyPackage+              -> PackageStatus+packageStatus installedPkgIndex cpkg =   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of     [] -> NewPackage     ps ->  case filter ((== packageId cpkg)                         . Installed.sourcePackageId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)-      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)+      pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)                                 (changes pkg cpkg)    where@@ -560,18 +608,22 @@     changes :: Installed.InstalledPackageInfo             -> ReadyPackage             -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' =-      filter changed-      $ mergeBy (comparing packageName)-        -- get dependencies of installed package (convert to source pkg ids via-        -- index)-        (nub . sort . concatMap-         (maybeToList . fmap Installed.sourcePackageId .-          PackageIndex.lookupInstalledPackageId installedPkgIndex) .-         Installed.depends $ pkg)-        -- get dependencies of configured package-        (nub . sort . depends $ pkg')+    changes pkg pkg' = filter changed $+      mergeBy (comparing packageName)+        -- 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 =+        nub+      . sort+      . map Installed.sourcePackageId+      . catMaybes+      . map (PackageIndex.lookupUnitId installedPkgIndex)+     changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True @@ -597,7 +649,7 @@     showPkg (pkg, _) = display (packageId pkg) ++                        showLatest (pkg) -    showPkgAndReason (pkg', pr) = display (packageId pkg') +++    showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') ++           showLatest pkg' ++           showFlagAssignment (nonDefaultFlags pkg') ++           showStanzas (stanzas pkg') ++@@ -607,9 +659,10 @@             NewVersion _   -> " (new version)"             Reinstall _ cs -> " (reinstall)" ++ case cs of                 []   -> ""-                diff -> " (changes: "  ++ intercalate ", " (map change diff) ++ ")"+                diff -> " (changes: "  ++ intercalate ", " (map change diff)+                        ++ ")" -    showLatest :: ReadyPackage -> String+    showLatest :: Package srcpkg => srcpkg -> String     showLatest pkg = case mLatestVersion of         Just latestVersion ->             if packageVersion pkg < latestVersion@@ -627,22 +680,21 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ReadyPackage -> FlagAssignment-    nonDefaultFlags (ReadyPackage spkg fa _ _) =+    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment+    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =       let defaultAssignment =             toFlagAssignment              (genPackageFlags (Source.packageDescription spkg))       in  fa \\ defaultAssignment -    stanzas :: ReadyPackage -> [OptionalStanza]-    stanzas (ReadyPackage _ _ sts _) = sts+    stanzas :: ConfiguredPackage -> [OptionalStanza]+    stanzas (ConfiguredPackage _ _ sts _) = sts      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((' ' :) . showStanza)     showStanza TestStanzas  = "*test"     showStanza BenchStanzas = "*bench" -    -- FIXME: this should be a proper function in a proper place     showFlagAssignment :: FlagAssignment -> String     showFlagAssignment = concatMap ((' ' :) . showFlagValue)     showFlagValue (f, True)   = '+' : showFlagName f@@ -658,8 +710,12 @@                   = " (via: " ++ unwords (map display rdeps) ++  ")"                 | otherwise = "" -    revDepGraphEdges = [ (rpid,packageId pkg) | (pkg,_) <- plan, rpid <- depends pkg ]+    revDepGraphEdges :: [(PackageId, PackageId)]+    revDepGraphEdges = [ (rpid, packageId pkg)+                       | (pkg@(ReadyPackage _ deps), _) <- plan+                       , rpid <- Installed.sourcePackageId <$> CD.flatDeps deps ] +    revDeps :: Map.Map PackageId [PackageId]     revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)  -- ------------------------------------------------------------@@ -668,22 +724,24 @@  -- | Report a solver failure. This works slightly differently to -- 'postInstallActions', as (by definition) we don't have an install plan.-reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO ()+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String+                      -> IO () reportPlanningFailure verbosity   (_, _, comp, platform, _, _, _   ,_, configFlags, _, installFlags, _)-  (_, sourcePkgDb, _, pkgSpecifiers)+  (_, sourcePkgDb, _, _, pkgSpecifiers, _)   message = do    when reportFailure $ do      -- Only create reports for explicitly named packages-    let pkgids =-          filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $+    let pkgids = filter+          (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $           mapMaybe theSpecifiedPackage pkgSpecifiers -        buildReports = BuildReports.fromPlanningFailure platform (compilerId comp)-          pkgids (configConfigurationsFlags configFlags)+        buildReports = BuildReports.fromPlanningFailure platform+                       (compilerId comp) pkgids+                       (configConfigurationsFlags configFlags)      when (not (null buildReports)) $       info verbosity $@@ -692,13 +750,14 @@      -- Save reports     BuildReports.storeLocal (compilerInfo comp)-                            (fromNubList $ installSummaryFile installFlags) buildReports platform+                            (fromNubList $ installSummaryFile installFlags)+                            buildReports platform      -- Save solver log     case logFile of       Nothing -> return ()       Just template -> forM_ pkgids $ \pkgid ->-        let env = initialPathTemplateEnv pkgid dummyPackageKey+        let env = initialPathTemplateEnv pkgid dummyIpid                     (compilerInfo comp) platform             path = fromPathTemplate $ substPathTemplate env template         in  writeFile path message@@ -707,12 +766,13 @@     reportFailure = fromFlag (installReportPlanningFailure installFlags)     logFile = flagToMaybe (installLogFile installFlags) -    -- A PackageKey is calculated from the transitive closure of+    -- A IPID is calculated from the transitive closure of     -- dependencies, but when the solver fails we don't have that.     -- So we fail.-    dummyPackageKey = error "reportPlanningFailure: package key not available"+    dummyIpid = error "reportPlanningFailure: installed package ID not available" --- | If a 'PackageSpecifier' refers to a single package, return Just that package.+-- | If a 'PackageSpecifier' refers to a single package, return Just that+-- package. theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec =   case pkgSpec of@@ -756,9 +816,12 @@       [ World.WorldPkgInfo dep []       | UserTargetNamed dep <- targets ] -  let buildReports = BuildReports.fromInstallPlan installPlan-  BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports-    (InstallPlan.planPlatform installPlan)+  let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)+                                                  installPlan+  BuildReports.storeLocal (compilerInfo comp)+                          (fromNubList $ installSummaryFile installFlags)+                          buildReports+                          platform   when (reportingLevel >= AnonymousReports) $     BuildReports.storeAnonymous buildReports   when (reportingLevel == DetailedReports) $@@ -767,7 +830,7 @@   regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox                          configFlags installFlags installPlan -  symlinkBinaries verbosity comp configFlags installFlags installPlan+  symlinkBinaries verbosity platform comp configFlags installFlags installPlan    printBuildFailures installPlan @@ -794,7 +857,8 @@          createDirectoryIfMissing True reportsDir -- FIXME          writeFile reportFile (show (BuildReports.show report, buildLog)) -  | (report, Just Repo { repoKind = Left remoteRepo }) <- reports+  | (report, Just repo) <- reports+  , Just remoteRepo <- [maybeRepoRemote repo]   , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]    where@@ -858,8 +922,8 @@         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs -        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True-        installedDocs _                                              = False+        installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True+        installedDocs _                                                = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False @@ -877,12 +941,15 @@   symlinkBinaries :: Verbosity-                -> Compiler+                -> Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags-                -> InstallPlan -> IO ()-symlinkBinaries verbosity comp configFlags installFlags plan = do-  failed <- InstallSymlink.symlinkBinaries comp configFlags installFlags plan+                -> InstallPlan+                -> IO ()+symlinkBinaries verbosity platform comp configFlags installFlags plan = do+  failed <- InstallSymlink.symlinkBinaries platform comp+                                           configFlags installFlags+                                           plan   case failed of     [] -> return ()     [(_, exe, path)] ->@@ -904,7 +971,8 @@     bindir = fromFlag (installSymlinkBinDir installFlags)  -printBuildFailures :: InstallPlan -> IO ()+printBuildFailures :: InstallPlan+                   -> IO () printBuildFailures plan =   case [ (pkg, reason)        | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of@@ -948,15 +1016,17 @@ -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo-                            -> Compiler -> Platform -> InstallPlan+                            -> Compiler -> Platform+                            -> InstallPlan                             -> IO () updateSandboxTimestampsFile (UseSandbox sandboxDir)                             (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))                             comp platform installPlan =   withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do-    let allInstalled = [ pkg | InstallPlan.Installed pkg _+    let allInstalled = [ pkg | InstallPlan.Installed pkg _ _                             <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]+        allSrcPkgs   = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _+                            <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]     allPathsCanonical <- mapM tryCanonicalizePath allPaths@@ -975,7 +1045,7 @@  -- | If logging is enabled, contains location of the log file and the verbosity -- level for logging.-type UseLogFile = Maybe (PackageIdentifier -> PackageKey -> FilePath, Verbosity)+type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)  performInstallations :: Verbosity                      -> InstallArgs@@ -983,7 +1053,7 @@                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity-  (packageDBs, _, comp, _, conf, useSandbox, _,+  (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do @@ -1000,23 +1070,21 @@   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -   executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->-    -- Calculate the package key (ToDo: Is this right for source install)-    let pkg_key = readyPackageKey comp rpkg in     installReadyPackage platform cinfo configFlags                         rpkg $ \configFlags' src pkg pkgoverride ->-      fetchSourcePackage verbosity fetchLimit src $ \src' ->+      fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->         installLocalPackage verbosity buildLimit                             (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key-                                 (setupScriptOptions installedPkgIndex cacheLock)-                                 miscOptions configFlags' installFlags haddockFlags-                                 cinfo platform pkg pkgoverride mpath useLogFile+          installUnpackedPackage verbosity buildLimit installLock numJobs+                                 (setupScriptOptions installedPkgIndex+                                  cacheLock rpkg)+                                 miscOptions configFlags'+                                 installFlags haddockFlags+                                 cinfo platform pkg rpkg pkgoverride mpath useLogFile    where-    platform = InstallPlan.planPlatform installPlan-    cinfo    = InstallPlan.planCompiler installPlan+    cinfo = compilerInfo comp      numJobs         = determineNumJobs (installNumJobs installFlags)     numFetchJobs    = 2@@ -1024,31 +1092,19 @@     distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                       (configDistPref configFlags) -    setupScriptOptions index lock = SetupScriptOptions {-      useCabalVersion  = chooseCabalVersion configExFlags-                         (libVersion miscOptions),-      useCompiler      = Just comp,-      usePlatform      = Just platform,-      -- Hack: we typically want to allow the UserPackageDB for finding the-      -- Cabal lib when compiling any Setup.hs even if we're doing a global-      -- install. However we also allow looking in a specific package db.-      usePackageDB     = if UserPackageDB `elem` packageDBs-                           then packageDBs-                           else let (db@GlobalPackageDB:dbs) = packageDBs-                                 in db : UserPackageDB : dbs,-                                --TODO: use Ord instance:-                                -- insert UserPackageDB packageDBs-      usePackageIndex  = if UserPackageDB `elem` packageDBs-                           then Just index-                           else Nothing,-      useProgramConfig = conf,-      useDistPref      = distPref,-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing,-      forceExternalSetupMethod = parallelInstall,-      useWin32CleanHack        = False,-      setupCacheLock   = Just lock-    }+    setupScriptOptions index lock rpkg =+      configureSetupScript+        packageDBs+        comp+        platform+        conf+        distPref+        (chooseCabalVersion configFlags (libVersion miscOptions))+        (Just lock)+        parallelInstall+        index+        (Just rpkg)+     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags) @@ -1089,11 +1145,12 @@           | parallelInstall                   = False           | otherwise                         = False -    substLogFileName :: PathTemplate -> PackageIdentifier -> PackageKey -> FilePath-    substLogFileName template pkg pkg_key = fromPathTemplate-                                          . substPathTemplate env-                                          $ template-      where env = initialPathTemplateEnv (packageId pkg) pkg_key+    substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath+    substLogFileName template pkg ipid = fromPathTemplate+                                  . substPathTemplate env+                                  $ template+      where env = initialPathTemplateEnv (packageId pkg)+                  ipid                   (compilerInfo comp) platform      miscOptions  = InstallMisc {@@ -1108,12 +1165,12 @@  executeInstallPlan :: Verbosity                    -> Compiler-                   -> JobControl IO (PackageId, PackageKey, BuildResult)+                   -> JobControl IO (PackageId, UnitId, BuildResult)                    -> UseLogFile                    -> InstallPlan                    -> (ReadyPackage -> IO BuildResult)                    -> IO InstallPlan-executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =+executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg =     tryNewTasks 0 plan0   where     tryNewTasks taskCount plan = do@@ -1125,10 +1182,13 @@             [ do info verbosity $ "Ready to install " ++ display pkgid                  spawnJob jobCtl $ do                    buildResult <- installPkg pkg-                   return (packageId pkg, pkg_key, buildResult)+                   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-                  pkg_key = readyPackageKey comp pkg ]+            , let pkgid = packageId pkg ]            let taskCount' = taskCount + length pkgs               plan'      = InstallPlan.processing pkgs plan@@ -1136,18 +1196,21 @@      waitForTasks taskCount plan = do       info verbosity $ "Waiting for install task to finish..."-      (pkgid, pkg_key, buildResult) <- collectJob jobCtl-      printBuildResult pkgid pkg_key buildResult+      (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) =-      InstallPlan.completed (Source.fakeInstalledPackageId pkgid) buildSuccess+    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan+               -> InstallPlan+    updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =+        InstallPlan.completed (Source.fakeUnitId pkgid)+                              mipkg buildSuccess      updatePlan pkgid (Left buildFailure) =-      InstallPlan.failed    (Source.fakeInstalledPackageId pkgid) buildFailure depsFailure+        InstallPlan.failed (Source.fakeUnitId pkgid)+                           buildFailure depsFailure       where         depsFailure = DependentFailed pkgid         -- So this first pkgid failed for whatever reason (buildFailure).@@ -1157,8 +1220,8 @@      -- Print build log if something went wrong, and 'Installed $PKGID'     -- otherwise.-    printBuildResult :: PackageId -> PackageKey -> BuildResult -> IO ()-    printBuildResult pkgid pkg_key buildResult = case buildResult of+    printBuildResult :: PackageId -> UnitId -> BuildResult -> IO ()+    printBuildResult pkgid ipid buildResult = case buildResult of         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid@@ -1166,7 +1229,7 @@             case useLogFile of               Nothing                 -> return ()               Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid pkg_key+                let logName = mkLogFileName pkgid ipid                 putStr $ "Build log ( " ++ logName ++ " ):\n"                 printFile logName @@ -1182,25 +1245,29 @@ -- NB: when updating this function, don't forget to also update -- 'configurePackage' in D.C.Configure. installReadyPackage :: Platform -> CompilerInfo-                       -> ConfigFlags-                       -> ReadyPackage-                       -> (ConfigFlags -> PackageLocation (Maybe FilePath)-                                       -> PackageDescription-                                       -> PackageDescriptionOverride -> a)-                       -> a+                    -> ConfigFlags+                    -> ReadyPackage+                    -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                    -> PackageDescription+                                    -> PackageDescriptionOverride+                                    -> a)+                    -> a installReadyPackage platform cinfo configFlags-  (ReadyPackage (SourcePackage _ gpkg source pkgoverride)-   flags stanzas deps)-  installPkg = installPkg configFlags {+                    (ReadyPackage (ConfiguredPackage+                                    (SourcePackage _ gpkg source pkgoverride)+                                    flags stanzas _)+                                   deps)+                    installPkg =+  installPkg configFlags {     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 <- deps ],+                         | deppkg <- CD.nonSetupDeps deps ],     configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                            Installed.installedPackageId deppkg)-                         | deppkg <- deps ],+                            Installed.installedUnitId deppkg)+                         | deppkg <- CD.nonSetupDeps deps ],     -- Use '--exact-configuration' if supported.     configExactConfiguration = toFlag True,     configBenchmarks         = toFlag False,@@ -1215,17 +1282,18 @@  fetchSourcePackage   :: Verbosity+  -> RepoContext   -> JobLimit   -> PackageLocation (Maybe FilePath)   -> (PackageLocation FilePath -> IO BuildResult)   -> IO BuildResult-fetchSourcePackage verbosity fetchLimit src installPkg = do+fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do   fetched <- checkFetched src   case fetched of     Just src' -> installPkg src'     Nothing   -> onFailure DownloadFailed $ do                    loc <- withJobLimit fetchLimit $-                            fetchPackage verbosity src+                            fetchPackage verbosity repoCtxt src                    installPkg loc  @@ -1314,7 +1382,6 @@   -> JobLimit   -> Lock   -> Int-  -> PackageKey   -> SetupScriptOptions   -> InstallMisc   -> ConfigFlags@@ -1323,14 +1390,15 @@   -> CompilerInfo   -> 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 pkg_key+installUnpackedPackage verbosity buildLimit installLock numJobs                        scriptOptions miscOptions                        configFlags installFlags haddockFlags-                       cinfo platform pkg pkgoverride workingDir useLogFile = do+                       cinfo platform pkg rpkg pkgoverride workingDir useLogFile = do    -- Override the .cabal file if necessary   case pkgoverride of@@ -1343,9 +1411,15 @@                     ++ " 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 configFlags+  configFlags' <- addDefaultInstallDirs ipid configFlags   -- Filter out flags not supported by the old versions of the Cabal lib.   let configureFlags :: Version -> ConfigFlags       configureFlags  = filterConfigureFlags configFlags' {@@ -1353,51 +1427,53 @@       }    -- Path to the optional log file.-  mLogPath <- maybeLogPath--  -- Configure phase-  onFailure ConfigureFailed $ withJobLimit buildLimit $ do-    when (numJobs > 1) $ notice verbosity $-      "Configuring " ++ display pkgid ++ "..."-    setup configureCommand configureFlags mLogPath+  mLogPath <- maybeLogPath ipid -  -- Build phase-    onFailure BuildFailed $ do+  logDirChange (maybe putStr appendFile mLogPath) workingDir $ do+    -- Configure phase+    onFailure ConfigureFailed $ withJobLimit buildLimit $ do       when (numJobs > 1) $ notice verbosity $-        "Building " ++ display pkgid ++ "..."-      setup buildCommand' buildFlags mLogPath+        "Configuring " ++ display pkgid ++ "..."+      setup configureCommand configureFlags mLogPath -  -- Doc generation phase-      docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags' mLogPath-                 return DocsOk)-               `catchIO`   (\_ -> return DocsFailed)-               `catchExit` (\_ -> return DocsFailed)-        else return DocsNotTried+    -- Build phase+      onFailure BuildFailed $ do+        when (numJobs > 1) $ notice verbosity $+          "Building " ++ display pkgid ++ "..."+        setup buildCommand' buildFlags mLogPath -  -- Tests phase-      onFailure TestsFailed $ do-        when (testsEnabled && PackageDescription.hasTests pkg) $-            setup Cabal.testCommand testFlags mLogPath+    -- Doc generation phase+        docsResult <- if shouldHaddock+          then (do setup haddockCommand haddockFlags' mLogPath+                   return DocsOk)+                 `catchIO`   (\_ -> return DocsFailed)+                 `catchExit` (\_ -> return DocsFailed)+          else return DocsNotTried -        let testsResult | testsEnabled = TestsOk-                        | otherwise = TestsNotTried+    -- Tests phase+        onFailure TestsFailed $ do+          when (testsEnabled && PackageDescription.hasTests pkg) $+              setup Cabal.testCommand testFlags mLogPath -      -- Install phase-        onFailure InstallFailed $ criticalSection installLock $ do-          -- Capture installed package configuration file-          maybePkgConf <- maybeGenPkgConf mLogPath+          let testsResult | testsEnabled = TestsOk+                          | otherwise = TestsNotTried -          -- Actual installation-          withWin32SelfUpgrade verbosity pkg_key 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))+        -- Install phase+          onFailure InstallFailed $ criticalSection installLock $ do+            -- Capture installed package configuration file+            maybePkgConf <- maybeGenPkgConf mLogPath +            -- Actual installation+            withWin32SelfUpgrade verbosity ipid 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))+   where     pkgid            = packageId pkg     buildCommand'    = buildCommand defaultProgramConfiguration@@ -1428,8 +1504,8 @@     verbosity' = maybe verbosity snd useLogFile     tempTemplate name = name ++ "-" ++ display pkgid -    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags-    addDefaultInstallDirs configFlags' = do+    addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs ipid configFlags' = do       defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False       return $ configFlags' {           configInstallDirs = fmap Cabal.Flag .@@ -1439,7 +1515,7 @@           }         where           CompilerId flavor _ = compilerInfoId cinfo-          env         = initialPathTemplateEnv pkgid pkg_key cinfo platform+          env         = initialPathTemplateEnv pkgid ipid cinfo platform           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') @@ -1468,12 +1544,12 @@       die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"             ++ show perror -    maybeLogPath :: IO (Maybe FilePath)-    maybeLogPath =+    maybeLogPath :: UnitId -> IO (Maybe FilePath)+    maybeLogPath ipid =       case useLogFile of          Nothing                 -> return Nothing          Just (mkLogFileName, _) -> do-           let logFileName = mkLogFileName (packageId pkg) pkg_key+           let logFileName = mkLogFileName (packageId pkg) ipid                logDir      = takeDirectory logFileName            unless (null logDir) $ createDirectoryIfMissing True logDir            logFileExists <- doesFileExist logFileName@@ -1482,9 +1558,8 @@      setup cmd flags mLogPath =       Exception.bracket-      (maybe (return Nothing)-             (\path -> Just `fmap` openFile path AppendMode) mLogPath)-      (maybe (return ()) hClose)+      (traverse (\path -> openFile path AppendMode) mLogPath)+      (traverse_ hClose)       (\logFileHandle ->         setupWrapper verbosity           scriptOptions { useLoggingHandle = logFileHandle@@ -1522,14 +1597,14 @@ -- ------------------------------------------------------------  withWin32SelfUpgrade :: Verbosity-                     -> PackageKey+                     -> UnitId                      -> ConfigFlags                      -> CompilerInfo                      -> Platform                      -> PackageDescription                      -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity pkg_key configFlags cinfo platform pkg action = do+withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1557,9 +1632,10 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid pkg_key+                           pkgid ipid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid pkg_key cinfo platform+          where env = InstallDirs.initialPathTemplateEnv pkgid ipid+                      cinfo platform
Distribution/Client/InstallPlan.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.InstallPlan@@ -13,85 +15,80 @@ ----------------------------------------------------------------------------- module Distribution.Client.InstallPlan (   InstallPlan,-  ConfiguredPackage(..),-  PlanPackage(..),+  GenericInstallPlan,+  PlanPackage,+  GenericPlanPackage(..),    -- * Operations on 'InstallPlan's   new,   toList,+  mapPreservingGraph,+   ready,   processing,   completed,   failed,   remove,+  preexisting,+  preinstalled,+   showPlanIndex,   showInstallPlan, -  -- ** Query functions-  planPlatform,-  planCompiler,-   -- * Checking validity of plans   valid,   closed,   consistent,   acyclic,-  configuredPackageValid,    -- ** Details on invalid plans   PlanProblem(..),   showPlanProblem,-  PackageProblem(..),-  showPackageProblem,   problems,-  configuredPackageProblems++  -- ** Querying the install plan+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,   ) where -import Distribution.Client.Types-         ( SourcePackage(packageDescription), ConfiguredPackage(..)-         , ReadyPackage(..), readyPackageToConfiguredPackage-         , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas-         , InstalledPackage(..), fakeInstalledPackageId )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo ) import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName-         , PackageFixedDeps(..), Dependency(..), InstalledPackageId-         , PackageInstalled(..) )+         ( PackageIdentifier(..), PackageName(..), Package(..)+         , HasUnitId(..), UnitId(..) )+import Distribution.Client.Types+         ( BuildSuccess, BuildFailure+         , PackageFixedDeps(..), ConfiguredPackage+         , GenericReadyPackage(..), fakeUnitId ) import Distribution.Version-         ( Version, withinRange )-import Distribution.PackageDescription-         ( GenericPackageDescription(genPackageFlags)-         , Flag(flagName), FlagName(..) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )+         ( Version )+import Distribution.Client.ComponentDeps (ComponentDeps)+import qualified Distribution.Client.ComponentDeps as CD import Distribution.Simple.PackageIndex-         ( PackageIndex, FakeMap )+         ( 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 Distribution.System-         ( Platform )-import Distribution.Compiler-         ( CompilerInfo(..) )-import Distribution.Client.Utils-         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Utils-         ( comparing, intercalate )-import qualified Distribution.InstalledPackageInfo as Installed  import Data.List-         ( sort, sortBy )+         ( foldl', intercalate ) import Data.Maybe-         ( fromMaybe, maybeToList )+         ( 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 Data.Maybe (catMaybes) import qualified Data.Map as Map+import qualified Data.Traversable as T -type PlanIndex = PackageIndex PlanPackage  -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve.@@ -135,115 +132,195 @@ -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. -data PlanPackage = PreExisting InstalledPackage-                 | Configured  ConfiguredPackage-                 | Processing  ReadyPackage-                 | Installed   ReadyPackage BuildSuccess-                 | Failed      ConfiguredPackage BuildFailure-                   -- ^ NB: packages in the Failed state can be *either* Ready-                   -- or Configured.+-- | 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 Package PlanPackage where-  packageId (PreExisting pkg) = packageId pkg-  packageId (Configured  pkg) = packageId pkg-  packageId (Processing pkg)  = packageId pkg-  packageId (Installed pkg _) = packageId pkg-  packageId (Failed    pkg _) = packageId pkg+instance (Binary ipkg, Binary srcpkg, Binary  iresult, Binary  ifailure)+      => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure) -instance PackageFixedDeps PlanPackage 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+type PlanPackage = GenericPlanPackage+                   InstalledPackageInfo ConfiguredPackage+                   BuildSuccess BuildFailure -instance PackageInstalled PlanPackage where-  installedPackageId (PreExisting pkg)   = installedPackageId pkg-  installedPackageId (Configured  pkg)   = installedPackageId pkg-  installedPackageId (Processing  pkg)   = installedPackageId pkg+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-  installedPackageId (Installed _ (BuildOk _ _ (Just ipkg))) = installedPackageId ipkg-  installedPackageId (Installed   pkg _) = installedPackageId pkg-  installedPackageId (Failed      pkg _) = installedPackageId pkg+  installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg+  installedUnitId (Installed rpkg _        _) = installedUnitId rpkg+  installedUnitId (Failed      spkg        _) = installedUnitId spkg -  installedDepends (PreExisting pkg) = installedDepends pkg-  installedDepends (Configured  pkg) = installedDepends pkg-  installedDepends (Processing pkg)  = installedDepends pkg-  installedDepends (Installed _ (BuildOk _ _ (Just ipkg))) = installedDepends ipkg-  installedDepends (Installed pkg _) = installedDepends pkg-  installedDepends (Failed    pkg _) = installedDepends pkg -data InstallPlan = InstallPlan {-    planIndex    :: PlanIndex,-    planFakeMap  :: FakeMap,-    planGraph    :: Graph,-    planGraphRev :: Graph,-    planPkgOf    :: Graph.Vertex -> PlanPackage,-    planVertexOf :: InstalledPackageId -> Graph.Vertex,-    planPlatform :: Platform,-    planCompiler :: CompilerInfo+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   } -invariant :: InstallPlan -> Bool+-- | 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 (planPlatform plan) (planCompiler plan) (planFakeMap plan) (planIndex 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 -showPlanIndex :: PlanIndex -> String+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 (installedPackageId p) ++ ")"+                ++ display (installedUnitId p) ++ ")" -showInstallPlan :: InstallPlan -> String+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)))+    "fake map:\n  " +++    intercalate "\n  " (map showKV (Map.toList (planFakeMap plan)))   where showKV (k,v) = display k ++ " -> " ++ display v -showPlanPackageTag :: PlanPackage -> String-showPlanPackageTag (PreExisting _) = "PreExisting"-showPlanPackageTag (Configured _)  = "Configured"-showPlanPackageTag (Processing _)  = "Processing"-showPlanPackageTag (Installed _ _) = "Installed"-showPlanPackageTag (Failed _ _)    = "Failed"+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 :: Platform -> CompilerInfo -> PlanIndex-    -> Either [PlanProblem] InstallPlan-new platform cinfo index =+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 -> (fakeInstalledPackageId (packageId p), installedPackageId p))+              . map (\p -> (fakeUnitId (packageId p)+                           ,installedUnitId p))               . filter isPreExisting               $ PackageIndex.allPackages index in-  case problems platform cinfo fakeMap index of-    [] -> Right InstallPlan {-            planIndex    = index,-            planFakeMap  = fakeMap,-            planGraph    = graph,-            planGraphRev = Graph.transposeG graph,-            planPkgOf    = vertexToPkgId,-            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,-            planPlatform = platform,-            planCompiler = cinfo-          }-      where (graph, vertexToPkgId, pkgIdToVertex) =-              PackageIndex.dependencyGraph index-              -- NB: doesn't need to know planFakeMap because the-              -- fakemap is empty at this point.-            noSuchPkgId = internalError "package is not in the graph"+  case problems fakeMap indepGoals index of+    []    -> Right (mkInstallPlan index fakeMap indepGoals)     probs -> Left probs -toList :: InstallPlan -> [PlanPackage]+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@@ -252,11 +329,14 @@ -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. ---remove :: (PlanPackage -> Bool)-       -> InstallPlan-       -> Either [PlanProblem] InstallPlan+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 (planPlatform plan) (planCompiler plan) newIndex+    new (planIndepGoals plan) newIndex   where     newIndex = PackageIndex.fromList $                  filter (not . shouldRemove) (toList plan)@@ -265,7 +345,9 @@ -- configured state and have all their dependencies installed already. -- The plan is complete if the result is @[]@. ---ready :: InstallPlan -> [ReadyPackage]+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@@ -274,29 +356,36 @@     configuredPackages = [ pkg | Configured pkg <- toList plan ]     processingPackages = [ pkg | Processing pkg <- toList plan] -    readyPackages :: [ReadyPackage]-    readyPackages =-      [ ReadyPackage srcPkg flags stanzas deps-      | pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages-        -- select only the package that have all of their deps installed:-      , deps <- maybeToList (hasAllInstalledDeps pkg)-      ]+    readyPackages :: [GenericReadyPackage srcpkg ipkg]+    readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages) -    hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]-    hasAllInstalledDeps = mapM isInstalledDep . installedDepends+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 -    isInstalledDep :: InstalledPackageId -> Maybe Installed.InstalledPackageInfo+    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 PackageIndex.fakeLookupInstalledPackageId (planFakeMap plan) (planIndex plan) pkgid of-        Just (Configured  _)                            -> Nothing-        Just (Processing  _)                            -> Nothing-        Just (Failed    _ _)                            -> internalError depOnFailed-        Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg-        Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg-        Just (Installed _ (BuildOk _ _ Nothing))        -> internalError depOnNonLib-        Nothing                                         -> internalError incomplete+      -- 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"@@ -305,7 +394,11 @@ -- -- * The package must exist in the graph and be in the configured state. ---processing :: [ReadyPackage] -> InstallPlan -> InstallPlan+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 {@@ -319,25 +412,28 @@ -- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. ---completed :: InstalledPackageId-          -> BuildSuccess-          -> InstallPlan -> InstallPlan-completed pkgid buildResult plan = assert (invariant plan') plan'+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 buildResult+                  planFakeMap = insert_fake_mapping mipkg                               $ planFakeMap plan,                   planIndex = PackageIndex.insert installed-                            . PackageIndex.deleteInstalledPackageId pkgid+                            . 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) buildResult-    insert_fake_mapping (BuildOk _ _ (Just ipi)) = Map.insert pkgid (installedPackageId ipi)-    insert_fake_mapping _ = id+    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.@@ -345,28 +441,31 @@ -- * The package must exist in the graph and be in the processing -- state. ---failed :: InstalledPackageId -- ^ The id of the package that failed to install-       -> BuildFailure      -- ^ The build result to use for the failed package-       -> BuildFailure      -- ^ The build result to use for its dependencies-       -> InstallPlan-       -> InstallPlan+failed :: (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                }-    pkg      = lookupProcessingPackage plan pkgid+    ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid     failures = PackageIndex.fromList-             $ Failed (readyPackageToConfiguredPackage pkg) buildResult+             $ Failed srcpkg buildResult              : [ Failed pkg' buildResult'                | Just pkg' <- map checkConfiguredPackage                             $ packagesThatDependOn plan pkgid ]  -- | Lookup the reachable packages in the reverse dependency graph. ---packagesThatDependOn :: InstallPlan-                     -> InstalledPackageId -> [PlanPackage]+packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure+                     -> UnitId+                     -> [GenericPlanPackage ipkg srcpkg iresult ifailure] packagesThatDependOn plan pkgid = map (planPkgOf plan)                           . tail                           . Graph.reachable (planGraphRev plan)@@ -375,23 +474,118 @@  -- | Lookup a package that we expect to be in the processing state. ---lookupProcessingPackage :: InstallPlan-                        -> InstalledPackageId -> ReadyPackage+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.lookupInstalledPackageId (planIndex plan) pkgid of+  case PackageIndex.lookupUnitId (planIndex plan) pkgid of     Just (Processing pkg) -> pkg-    _  -> internalError $ "not in processing state or no such pkg " ++ display pkgid+    _  -> 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 :: PlanPackage -> Maybe ConfiguredPackage+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 -- ------------------------------------------------------------@@ -402,23 +596,24 @@ -- -- * if the result is @False@ use 'problems' to get a detailed list. ---valid :: Platform -> CompilerInfo -> FakeMap -> PlanIndex -> Bool-valid platform cinfo fakeMap index = null (problems platform cinfo fakeMap index)+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 =-     PackageInvalid       ConfiguredPackage [PackageProblem]-   | PackageMissingDeps   PlanPackage [PackageIdentifier]-   | PackageCycle         [PlanPackage]+data PlanProblem ipkg srcpkg iresult ifailure =+     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg iresult ifailure)+                          [PackageIdentifier]+   | PackageCycle         [GenericPlanPackage ipkg srcpkg iresult ifailure]    | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  PlanPackage PlanPackage--showPlanProblem :: PlanProblem -> String-showPlanProblem (PackageInvalid pkg packageProblems) =-     "Package " ++ display (packageId pkg)-  ++ " has an invalid configuration, in particular:\n"-  ++ unlines [ "  " ++ showPackageProblem problem-             | problem <- packageProblems ]+   | 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: "@@ -443,36 +638,41 @@   ++ " which is in the " ++ showPlanState pkg'   ++ " state"   where-    showPlanState (PreExisting _) = "pre-existing"-    showPlanState (Configured  _) = "configured"-    showPlanState (Processing _)  = "processing"-    showPlanState (Installed _ _) = "installed"-    showPlanState (Failed    _ _) = "failed"+    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 :: Platform -> CompilerInfo -> FakeMap-         -> PlanIndex -> [PlanProblem]-problems platform cinfo fakeMap index =-     [ PackageInvalid pkg packageProblems-     | Configured pkg <- PackageIndex.allPackages index-     , let packageProblems = configuredPackageProblems platform cinfo pkg-     , not (null packageProblems) ]+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 . PackageIndex.fakeLookupInstalledPackageId fakeMap index) missingDeps))-     | (pkg, missingDeps) <- PackageIndex.brokenPackages' fakeMap index ]+     [ PackageMissingDeps pkg+       (catMaybes+        (map+         (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)+         missingDeps))+     | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]    ++ [ PackageCycle cycleGroup-     | cycleGroup <- PackageIndex.dependencyCycles' fakeMap index ]+     | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]    ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies' fakeMap index ]+     | (name, inconsistencies) <-+       PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]    ++ [ PackageStateInvalid pkg pkg'      | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PackageIndex.fakeLookupInstalledPackageId fakeMap index) (installedDepends pkg)+     , 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.@@ -480,8 +680,10 @@ -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --   which packages are involved in dependency cycles. ---acyclic :: PlanIndex -> Bool-acyclic = null . PackageIndex.dependencyCycles+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@@ -490,8 +692,10 @@ -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --   which packages depend on packages not in the index. ---closed :: PlanIndex -> Bool-closed = null . PackageIndex.brokenPackages+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.@@ -509,119 +713,76 @@ -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --   find out which packages are. ---consistent :: PlanIndex -> Bool-consistent = null . PackageIndex.dependencyInconsistencies+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 :: PlanPackage -> PlanPackage -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _) = 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 (Configured  _) (PreExisting _)   = True+stateDependencyRelation (Configured  _) (Configured  _)   = True+stateDependencyRelation (Configured  _) (Processing  _)   = True+stateDependencyRelation (Configured  _) (Installed _ _ _) = True -stateDependencyRelation (Processing  _) (PreExisting _) = True-stateDependencyRelation (Processing  _) (Installed _ _) = True+stateDependencyRelation (Processing  _) (PreExisting _)   = True+stateDependencyRelation (Processing  _) (Installed _ _ _) = True -stateDependencyRelation (Installed _ _) (PreExisting _) = True-stateDependencyRelation (Installed _ _) (Installed _ _) = True+stateDependencyRelation (Installed _ _ _) (PreExisting _)   = True+stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True -stateDependencyRelation (Failed    _ _) (PreExisting _) = 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 (Failed    _ _) (Configured  _)   = True+stateDependencyRelation (Failed    _ _) (Processing  _)   = True+stateDependencyRelation (Failed    _ _) (Installed _ _ _) = True+stateDependencyRelation (Failed    _ _) (Failed    _   _) = True -stateDependencyRelation _               _               = False+stateDependencyRelation _               _                 = False --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if--- in the configuration given by the flag assignment, all the package--- dependencies are satisfied by the specified packages.++-- | Compute the dependency closure of a package in a install plan ---configuredPackageValid :: Platform -> CompilerInfo -> ConfiguredPackage -> Bool-configuredPackageValid platform cinfo pkg =-  null (configuredPackageProblems platform cinfo pkg)+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) -data PackageProblem = DuplicateFlag FlagName-                    | MissingFlag   FlagName-                    | ExtraFlag     FlagName-                    | DuplicateDeps [PackageIdentifier]-                    | MissingDep    Dependency-                    | ExtraDep      PackageIdentifier-                    | InvalidDep    Dependency PackageIdentifier -showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag+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) -showPackageProblem (MissingFlag (FlagName flag)) =-  "missing an assignment for the flag: " ++ flag -showPackageProblem (ExtraFlag (FlagName flag)) =-  "extra flag given that is not used by the package: " ++ flag+topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure+                 -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+topologicalOrder plan =+    map (planPkgOf plan)+  . Graph.topSort+  $ planGraph plan -showPackageProblem (DuplicateDeps pkgids) =-     "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map display pkgids) -showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ display dep-  ++ " but no package has been selected to satisfy it."--showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ display pkgid-  ++ " but (with the given flag assignment) the package does not actually"-  ++ " depend on any version of that package."--showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ display dep-  ++ " but the configuration specifies " ++ display pkgid-  ++ " which does not satisfy the dependency."--configuredPackageProblems :: Platform -> CompilerInfo-                          -> ConfiguredPackage -> [PackageProblem]-configuredPackageProblems platform cinfo-  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) =-     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]-  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]-  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]-  ++ [ DuplicateDeps pkgs-     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]-  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]-  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]-  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps-                            , not (packageSatisfiesDependency pkgid dep) ]-  where-    mergedFlags = mergeBy compare-      (sort $ map flagName (genPackageFlags (packageDescription pkg)))-      (sort $ map fst specifiedFlags)--    mergedDeps = mergeBy-      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)-      (sortBy (comparing dependencyName) requiredDeps)-      (sortBy (comparing packageName)    specifiedDeps)--    packageSatisfiesDependency-      (PackageIdentifier name  version)-      (Dependency        name' versionRange) = assert (name == name') $-        version `withinRange` versionRange--    dependencyName (Dependency name _) = name--    requiredDeps :: [Dependency]-    requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags-         (const True)-         platform cinfo-         []-         (enableStanzas stanzas $ packageDescription pkg) of-        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg-        Left  _ -> error "configuredPackageInvalidDeps internal error"+reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure+                        -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+reverseTopologicalOrder plan =+    map (planPkgOf plan)+  . Graph.topSort+  $ planGraphRev plan
Distribution/Client/InstallSymlink.hs view
@@ -23,13 +23,14 @@ import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler+import Distribution.System -symlinkBinaries :: Compiler+symlinkBinaries :: Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags-                -> InstallPlan+                -> InstallPlan                  -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries _ _ _ _ = return []+symlinkBinaries _ _ _ _ _ = return []  symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"@@ -37,14 +38,16 @@ #else  import Distribution.Client.Types-         ( SourcePackage(..), ReadyPackage(..), enableStanzas )+         ( SourcePackage(..)+         , GenericReadyPackage(..), ReadyPackage, enableStanzas+         , ConfiguredPackage(..) , fakeUnitId) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan)  import Distribution.Package-         ( PackageIdentifier, Package(packageId), mkPackageKey, PackageKey )+         ( PackageIdentifier, Package(packageId), UnitId(..) ) import Distribution.Compiler          ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription@@ -55,9 +58,10 @@ import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple.Compiler-         ( Compiler, CompilerInfo(..), packageKeySupported )+         ( Compiler, compilerInfo, CompilerInfo(..) )+import Distribution.System+         ( Platform )  import System.Posix.Files          ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink@@ -96,12 +100,12 @@ -- controlled from the config file. Of course it only works on POSIX systems -- with symlinks so is not available to Windows users. ---symlinkBinaries :: Compiler+symlinkBinaries :: Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags                 -> InstallPlan                 -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries comp configFlags installFlags plan =+symlinkBinaries platform comp configFlags installFlags plan =   case flagToMaybe (installSymlinkBinDir installFlags) of     Nothing            -> return []     Just symlinkBinDir@@ -111,7 +115,7 @@ --    TODO: do we want to do this here? : --      createDirectoryIfMissing True publicBinDir       fmap catMaybes $ sequence-        [ do privateBinDir <- pkgBinDir pkg pkg_key+        [ do privateBinDir <- pkgBinDir pkg ipid              ok <- symlinkBinary                      publicBinDir  privateBinDir                      publicExeName privateExeName@@ -119,24 +123,27 @@                then return Nothing                else return (Just (pkgid, publicExeName,                                   privateBinDir </> privateExeName))-        | (ReadyPackage _ _flags _ deps, pkg, exe) <- exes+        | (ReadyPackage (ConfiguredPackage _ _flags _ _) _, pkg, exe) <- exes         , let pkgid  = packageId pkg-              pkg_key = mkPackageKey (packageKeySupported comp) pkgid-                                     (map Installed.packageKey deps) []+              -- This is a bit dodgy; probably won't work for Backpack packages+              ipid = fakeUnitId pkgid               publicExeName  = PackageDescription.exeName exe               privateExeName = prefix ++ publicExeName ++ suffix-              prefix = substTemplate pkgid pkg_key prefixTemplate-              suffix = substTemplate pkgid pkg_key suffixTemplate ]+              prefix = substTemplate pkgid ipid prefixTemplate+              suffix = substTemplate pkgid ipid suffixTemplate ]   where     exes =       [ (cpkg, pkg, exe)-      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan+      | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan       , let pkg   = pkgDescription cpkg       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ]      pkgDescription :: ReadyPackage -> PackageDescription-    pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =+    pkgDescription (ReadyPackage (ConfiguredPackage+                                    (SourcePackage _ pkg _ _)+                                    flags stanzas _)+                                  _) =       case finalizePackageDescription flags              (const True)              platform cinfo [] (enableStanzas stanzas pkg) of@@ -145,8 +152,8 @@      -- This is sadly rather complicated. We're kind of re-doing part of the     -- configuration for the package. :-(-    pkgBinDir :: PackageDescription -> PackageKey -> IO FilePath-    pkgBinDir pkg pkg_key = do+    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath+    pkgBinDir pkg ipid = do       defaultDirs <- InstallDirs.defaultInstallDirs                        compilerFlavor                        (fromFlag (configUserInstall configFlags))@@ -154,21 +161,20 @@       let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)           absoluteDirs = InstallDirs.absoluteInstallDirs-                           (packageId pkg) pkg_key+                           (packageId pkg) ipid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs       canonicalizePath (InstallDirs.bindir absoluteDirs) -    substTemplate pkgid pkg_key = InstallDirs.fromPathTemplate-                                . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid pkg_key+    substTemplate pkgid ipid = InstallDirs.fromPathTemplate+                             . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid ipid                                                      cinfo platform      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)     suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)-    platform         = InstallPlan.planPlatform plan-    cinfo            = InstallPlan.planCompiler plan+    cinfo            = compilerInfo comp     (CompilerId compilerFlavor _) = compilerInfoId cinfo  symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir
Distribution/Client/List.hs view
@@ -15,7 +15,8 @@  import Distribution.Package          ( PackageName(..), Package(..), packageName, packageVersion-         , Dependency(..), simplifyDependency )+         , Dependency(..), simplifyDependency+         , UnitId ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed@@ -42,13 +43,14 @@          ( Text(disp), display )  import Distribution.Client.Types-         ( SourcePackage(..), Repo, SourcePackageDb(..) )+         ( SourcePackage(..), SourcePackageDb(..) ) import Distribution.Client.Dependency.Types-         ( PackageConstraint(..), ExtDependency(..) )+         ( PackageConstraint(..) ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup-         ( GlobalFlags(..), ListFlags(..), InfoFlags(..) )+         ( GlobalFlags(..), ListFlags(..), InfoFlags(..)+         , RepoContext(..) ) import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils@@ -74,15 +76,15 @@ -- | Return a list of packages matching given search strings. getPkgList :: Verbosity            -> PackageDBStack-           -> [Repo]+           -> RepoContext            -> Compiler            -> ProgramConfiguration            -> ListFlags            -> [String]            -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repos comp conf listFlags pats = do+getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb))@@ -130,7 +132,7 @@ -- | Show information about packages. list :: Verbosity      -> PackageDBStack-     -> [Repo]+     -> RepoContext      -> Compiler      -> ProgramConfiguration      -> ListFlags@@ -160,7 +162,7 @@  info :: Verbosity      -> PackageDBStack-     -> [Repo]+     -> RepoContext      -> Compiler      -> ProgramConfiguration      -> GlobalFlags@@ -170,11 +172,11 @@ info verbosity _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -info verbosity packageDBs repos comp conf+info verbosity packageDBs repoCtxt comp conf      globalFlags _listFlags userTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb   <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb))@@ -187,7 +189,7 @@                       (InstalledPackageIndex.allPackages installedPkgIndex)                    ++ map packageId                       (PackageIndex.allPackages sourcePkgIndex)-    pkgSpecifiers <- resolveUserTargets verbosity+    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)                        sourcePkgs' userTargets @@ -289,6 +291,11 @@     haveTarball       :: Bool   } +-- | Covers source dependencies and installed dependencies in+-- one type.+data ExtDependency = SourceDependency Dependency+                   | InstalledDependency UnitId+ showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo =   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $@@ -341,7 +348,7 @@    , entry "Source repo"   sourceRepo   orNotSpecified text    , entry "Executables"   executables  hideIfNull     (commaSep text)    , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)-   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)    , entry "Documentation" haddockHtml  showIfInstalled text    , entry "Cached"        haveTarball  alwaysShow     dispYesNo    , if not (hasLib pkginfo) then empty else@@ -374,6 +381,9 @@     dispFlag f = case flagName f of FlagName n -> text n     dispYesNo True  = text "Yes"     dispYesNo False = text "No"++    dispExtDep (SourceDependency    dep) = disp dep+    dispExtDep (InstalledDependency dep) = disp dep      isInstalled = not (null (installedVersions pkginfo))     hasExes = length (executables pkginfo) >= 2
+ Distribution/Client/Manpage.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Manpage+-- Copyright   :  (c) Maciek Makowski 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for building the manual page.++module Distribution.Client.Manpage+  ( -- * Manual page generation+    manpage+  ) where++import Distribution.Simple.Command+import Distribution.Client.Setup (globalCommand)++import Data.Char (toUpper)+import Data.List (intercalate)++data FileInfo = FileInfo String String -- ^ path, description++-- | A list of files that should be documented in the manual page.+files :: [FileInfo]+files =+  [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")+  , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")+  ]++-- | Produces a manual page with @troff@ markup.+manpage :: String -> [CommandSpec a] -> String+manpage pname commands = unlines $+  [ ".TH " ++ map toUpper pname ++ " 1"+  , ".SH NAME"+  , pname ++ " \\- a system for building and packaging Haskell libraries and programs"+  , ".SH SYNOPSIS"+  , ".B " ++ pname+  , ".I command"+  , ".RI < arguments |[ options ]>..."+  , ""+  , "Where the"+  , ".I commands"+  , "are"+  , ""+  ] +++  concatMap (commandSynopsisLines pname) commands +++  [ ".SH DESCRIPTION"+  , "Cabal is the standard package system for Haskell software. It helps people to configure, "+  , "build and install Haskell software and to distribute it easily to other users and developers."+  , ""+  , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "+  , "installing existing packages and developing new packages. "+  , "It can be used to work with local packages or to install packages from online package archives, "+  , "including automatically installing dependencies. By default it is configured to use Hackage, "+  , "which is Haskell’s central package archive that contains thousands of libraries and applications "+  , "in the Cabal package format."+  , ".SH OPTIONS"+  , "Global options:"+  , ""+  ] +++  optionsLines (globalCommand []) +++  [ ".SH COMMANDS"+  ] +++  concatMap (commandDetailsLines pname) commands +++  [ ".SH FILES"+  ] +++  concatMap fileLines files +++  [ ".SH BUGS"+  , "To browse the list of known issues or report a new one please see "+  , "https://github.com/haskell/cabal/labels/cabal-install."+  ]++commandSynopsisLines :: String -> CommandSpec action -> [String]+commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ".R - " ++ commandSynopsis ui+  , ".br"+  ]+commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []++commandDetailsLines :: String -> CommandSpec action -> [String]+commandDetailsLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ""+  , commandUsage ui pname+  , ""+  ] +++  optional commandDescription +++  optional commandNotes +++  [ "Flags:"+  , ".RS"+  ] +++  optionsLines ui +++  [ ".RE"+  , ""+  ]+  where+    optional field =+      case field ui of+        Just text -> [text pname, ""]+        Nothing   -> []+commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []++optionsLines :: CommandUI flags -> [String]+optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))++data ArgumentRequired = Optional | Required+type OptionArg = (ArgumentRequired, ArgPlaceHolder)++optionLines :: OptDescr flags -> [String]+optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =+  argOptionLines description optionChars optionStrings (Required, placeHolder)+optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =+  argOptionLines description optionChars optionStrings (Optional, placeHolder)+optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =+  optionLinesIfPresent trueChars trueStrings +++  optionLinesIfPresent falseChars falseStrings +++  optionDescriptionLines description+optionLines (ChoiceOpt options) =+  concatMap choiceLines options+  where+    choiceLines (description, (optionChars, optionStrings), _, _) =+      [ optionsLine optionChars optionStrings ] +++      optionDescriptionLines description++argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]+argOptionLines description optionChars optionStrings arg =+  [ optionsLine optionChars optionStrings+  , optionArgLine arg+  ] +++  optionDescriptionLines description++optionLinesIfPresent :: [Char] -> [String] -> [String]+optionLinesIfPresent optionChars optionStrings =+  if null optionChars && null optionStrings then []+  else                                           [ optionsLine optionChars optionStrings, ".br" ]++optionDescriptionLines :: String -> [String]+optionDescriptionLines description =+  [ ".RS"+  , description+  , ".RE"+  , ""+  ]++optionsLine :: [Char] -> [String] -> String+optionsLine optionChars optionStrings =+  intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)++shortOptions :: [Char] -> [String]+shortOptions = map (\c -> "\\-" ++ [c])++longOptions :: [String] -> [String]+longOptions = map (\s -> "\\-\\-" ++ s)++optionArgLine :: OptionArg -> String+optionArgLine (Required, placeHolder) = ".I " ++ placeHolder+optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"++fileLines :: FileInfo -> [String]+fileLines (FileInfo path description) =+  [ path+  , ".RS"+  , description+  , ".RE"+  , ""+  ]
+ Distribution/Client/PackageHash.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}++-- | Functions to calculate nix-style hashes for package ids.+--+-- The basic idea is simple, hash the combination of:+--+--   * the package tarball+--   * the ids of all the direct dependencies+--   * other local configuration (flags, profiling, etc)+--+module Distribution.Client.PackageHash (+    -- * Calculating package hashes+    PackageHashInputs(..),+    PackageHashConfigInputs(..),+    PackageSourceHash,+    hashedInstalledPackageId,+    hashPackageHashInputs,+    renderPackageHashInputs,++    -- * Low level hash choice+    HashValue,+    hashValue,+    showHashValue,+    readFileHashValue,+    hashFromTUF,+  ) where++import Distribution.Package+         ( PackageId, mkUnitId )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( FlagName(..), FlagAssignment )+import Distribution.Simple.Compiler+         ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)+         , ProfDetailLevel(..), showProfDetailLevel )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate )+import Distribution.Text+         ( display )+import Distribution.Client.Types+         ( InstalledPackageId )++import qualified Hackage.Security.Client    as Sec++import qualified Crypto.Hash.SHA256         as SHA256+import qualified Data.ByteString.Base16     as Base16+import qualified Data.ByteString.Char8      as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Set as Set+import           Data.Set (Set)++import Data.Maybe        (catMaybes)+import Data.List         (sortBy, intercalate)+import Data.Function     (on)+import Distribution.Compat.Binary (Binary(..))+import Control.Exception (evaluate)+import System.IO         (withBinaryFile, IOMode(..))+++-------------------------------+-- Calculating package hashes+--++-- | Calculate a 'InstalledPackageId' for a package using our nix-style+-- inputs hashing method.+--+hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageId pkghashinputs@PackageHashInputs{pkgHashPkgId} =+    mkUnitId $+         display pkgHashPkgId   -- to be a bit user friendly+      ++ "-"+      ++ showHashValue (hashPackageHashInputs pkghashinputs)++-- | All the information that contribues to a package's hash, and thus its+-- 'InstalledPackageId'.+--+data PackageHashInputs = PackageHashInputs {+       pkgHashPkgId         :: PackageId,+       pkgHashSourceHash    :: PackageSourceHash,+       pkgHashDirectDeps    :: Set InstalledPackageId,+       pkgHashOtherConfig   :: PackageHashConfigInputs+     }++type PackageSourceHash = HashValue++-- | Those parts of the package configuration that contribute to the+-- package hash.+--+data PackageHashConfigInputs = PackageHashConfigInputs {+       pkgHashCompilerId          :: CompilerId,+       pkgHashPlatform            :: Platform,+       pkgHashFlagAssignment      :: FlagAssignment, -- complete not partial+       pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure+       pkgHashVanillaLib          :: Bool,+       pkgHashSharedLib           :: Bool,+       pkgHashDynExe              :: Bool,+       pkgHashGHCiLib             :: Bool,+       pkgHashProfLib             :: Bool,+       pkgHashProfExe             :: Bool,+       pkgHashProfLibDetail       :: ProfDetailLevel,+       pkgHashProfExeDetail       :: ProfDetailLevel,+       pkgHashCoverage            :: Bool,+       pkgHashOptimization        :: OptimisationLevel,+       pkgHashSplitObjs           :: Bool,+       pkgHashStripLibs           :: Bool,+       pkgHashStripExes           :: Bool,+       pkgHashDebugInfo           :: DebugInfoLevel,+       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?+     }+  deriving Show+++-- | Calculate the overall hash to be used for an 'InstalledPackageId'.+--+hashPackageHashInputs :: PackageHashInputs -> HashValue+hashPackageHashInputs = hashValue . renderPackageHashInputs++-- | Render a textual representation of the 'PackageHashInputs'.+--+-- The 'hashValue' of this text is the overall package hash.+--+renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString+renderPackageHashInputs PackageHashInputs{+                          pkgHashPkgId,+                          pkgHashSourceHash,+                          pkgHashDirectDeps,+                          pkgHashOtherConfig =+                            PackageHashConfigInputs{..}+                        } =+    -- The purpose of this somewhat laboured rendering (e.g. why not just+    -- use show?) is so that existing package hashes do not change+    -- unnecessarily when new configuration inputs are added into the hash.++    -- In particular, the assumption is that when a new configuration input+    -- is included into the hash, that existing packages will typically get+    -- the default value for that feature. So if we avoid adding entries with+    -- the default value then most of the time adding new features will not+    -- change the hashes of existing packages and so fewer packages will need+    -- to be rebuilt. ++    --TODO: [nice to have] ultimately we probably want to put this config info+    -- into the ghc-pkg db. At that point this should probably be changed to+    -- use the config file infrastructure so it can be read back in again.+    LBS.pack $ unlines $ catMaybes+      [ entry "pkgid"       display pkgHashPkgId+      , entry "src"         showHashValue pkgHashSourceHash+      , entry "deps"        (intercalate ", " . map display+                                              . Set.toList) pkgHashDirectDeps+        -- and then all the config+      , entry "compilerid"  display pkgHashCompilerId+      , entry "platform"    display pkgHashPlatform+      , opt   "flags" []    showFlagAssignment pkgHashFlagAssignment+      , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs+      , opt   "vanilla-lib" True  display pkgHashVanillaLib+      , opt   "shared-lib"  False display pkgHashSharedLib+      , opt   "dynamic-exe" False display pkgHashDynExe+      , opt   "ghci-lib"    False display pkgHashGHCiLib+      , opt   "prof-lib"    False display pkgHashProfLib+      , opt   "prof-exe"    False display pkgHashProfExe+      , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail +      , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail +      , opt   "hpc"          False display pkgHashCoverage+      , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization+      , opt   "split-objs"   False display pkgHashSplitObjs+      , opt   "stripped-lib" False display pkgHashStripLibs+      , opt   "stripped-exe" True  display pkgHashStripExes+      , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo+      , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs+      , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs+      , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs+      , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix+      , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix+      ]+  where+    entry key     format value = Just (key ++ ": " ++ format 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++-----------------------------------------------+-- The specific choice of hash implementation+--++-- Is a crypto hash necessary here? One thing to consider is who controls the+-- inputs and what's the result of a hash collision. Obviously we should not+-- install packages we don't trust because they can run all sorts of code, but+-- if I've checked there's no TH, no custom Setup etc, is there still a+-- problem? If someone provided us a tarball that hashed to the same value as+-- some other package and we installed it, we could end up re-using that+-- installed package in place of another one we wanted. So yes, in general+-- there is some value in preventing intentional hash collisions in installed+-- package ids.++newtype HashValue = HashValue BS.ByteString+  deriving (Eq, Show)++instance Binary HashValue where+  put (HashValue digest) = put digest+  get = do+    digest <- get+    -- Cannot do any sensible validation here. Although we use SHA256+    -- for stuff we hash ourselves, we can also get hashes from TUF+    -- and that can in principle use different hash functions in future.+    return (HashValue digest)++-- | Hash some data. Currently uses SHA256.+--+hashValue :: LBS.ByteString -> HashValue+hashValue = HashValue . SHA256.hashlazy++showHashValue :: HashValue -> String+showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)++-- | Hash the content of a file. Uses SHA256.+--+readFileHashValue :: FilePath -> IO HashValue+readFileHashValue tarball =+    withBinaryFile tarball ReadMode $ \hnd ->+      evaluate . hashValue =<< LBS.hGetContents hnd++-- | Convert a hash from TUF metadata into a 'PackageSourceHash'.+--+-- Note that TUF hashes don't neessarily have to be SHA256, since it can+-- support new algorithms in future.+--+hashFromTUF :: Sec.Hash -> HashValue+hashFromTUF (Sec.Hash hashstr) =+    --TODO: [code cleanup] either we should get TUF to use raw bytestrings or+    -- perhaps we should also just use a base16 string as the internal rep.+    case Base16.decode (BS.pack hashstr) of+      (hash, trailing) | not (BS.null hash) && BS.null trailing+        -> HashValue hash+      _ -> error "hashFromTUF: cannot decode base16 hash"+
Distribution/Client/PackageIndex.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP           #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.PackageIndex@@ -43,39 +44,29 @@   -- ** Bulk queries   allPackages,   allPackagesByName,--  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,   ) where  import Prelude hiding (lookup) import Control.Exception (assert) import qualified Data.Map as Map import Data.Map (Map)-import qualified Data.Tree  as Tree-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Data.Array ((!))-import Data.List (groupBy, sortBy, nub, isInfixOf)+import Data.List (groupBy, sortBy, isInfixOf) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) #endif-import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes)+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), PackageFixedDeps(..) )+         , Dependency(Dependency) ) import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, equating, comparing)+         ( withinRange )+import Distribution.Simple.Utils+         ( lowercase, comparing )   -- | The collection of information about packages from one or more 'PackageDB's.@@ -91,15 +82,21 @@   --   (Map PackageName [pkg]) -  deriving (Show, Read, Functor)+  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 = merge+  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@@ -126,7 +123,7 @@ -- | Lookup a name in the index to get all packages that match that name -- case-sensitively. ---lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookup :: PackageIndex pkg -> PackageName -> [pkg] lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m  --@@ -228,14 +225,14 @@  -- | Get all the packages from the index. ---allPackages :: Package pkg => PackageIndex pkg -> [pkg]+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 :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName :: PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m  --@@ -296,7 +293,7 @@ -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. ---searchByName :: Package pkg => PackageIndex pkg+searchByName :: PackageIndex pkg              -> String -> [(PackageName, [pkg])] searchByName (PackageIndex m) name =     [ pkgs@@ -311,7 +308,7 @@ -- -- That is, all packages that contain the given string in their name. ---searchByNameSubstring :: Package pkg => PackageIndex pkg+searchByNameSubstring :: PackageIndex pkg                       -> String -> [(PackageName, [pkg])] searchByNameSubstring (PackageIndex m) searchterm =     [ pkgs@@ -319,172 +316,3 @@     , lsearchterm `isInfixOf` lowercase name ]   where     lsearchterm = lowercase searchterm------- * Special queries------- | 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-               => PackageIndex pkg-               -> [(pkg, [PackageIdentifier])]-brokenPackages index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- depends pkg-                         , isNothing (lookupPackageId index pkg') ]-  , not (null missing) ]---- | 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-                  => PackageIndex pkg-                  -> [PackageIdentifier]-                  -> Either (PackageIndex pkg)-                            [(pkg, [PackageIdentifier])]-dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of-  (completed, []) -> Left completed-  (completed, _)  -> Right (brokenPackages completed)-  where-    closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupPackageId completed (packageId pkg) of-        Just _  -> closure completed  failed pkgids-        Nothing -> closure completed' failed pkgids'-          where completed' = insert pkg completed-                pkgids'    = depends pkg ++ pkgids---- | Takes the transitive closure of the packages reverse dependencies.------ * The given 'PackageIdentifier's must be in the index.----reverseDependencyClosure :: PackageFixedDeps pkg-                         => PackageIndex pkg-                         -> [PackageIdentifier]-                         -> [pkg]-reverseDependencyClosure index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)--  where-    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index-    reverseDepGraph = Graph.transposeG depGraph-    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"--topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-topologicalOrder index = map toPkgId-                       . Graph.topSort-                       $ graph-  where (graph, toPkgId, _) = dependencyGraph index--reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-reverseTopologicalOrder index = map toPkgId-                              . Graph.topSort-                              . Graph.transposeG-                              $ graph-  where (graph, toPkgId, _) = dependencyGraph index---- | 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 :: PackageFixedDeps pkg-                          => PackageIndex pkg-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies index =-  [ (name, inconsistencies)-  | (name, uses) <- Map.toList inverseIndex-  , let inconsistencies = duplicatesBy uses-        versions = map snd inconsistencies-  , reallyIsInconsistent name (nub versions) ]--  where inverseIndex = Map.fromListWith (++)-          [ (packageName dep, [(packageId pkg, packageVersion dep)])-          | pkg <- allPackages index-          , dep <- depends pkg ]--        duplicatesBy = (\groups -> if length groups == 1-                                     then []-                                     else concat groups)-                     . groupBy (equating snd)-                     . sortBy (comparing snd)--        reallyIsInconsistent :: PackageName -> [Version] -> Bool-        reallyIsInconsistent _    []       = False-        reallyIsInconsistent name [v1, v2] =-          case (mpkg1, mpkg2) of-            (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2-                                   && pkgid2 `notElem` depends pkg1-            _ -> True-          where-            pkgid1 = PackageIdentifier name v1-            pkgid2 = PackageIdentifier name v2-            mpkg1 = lookupPackageId index pkgid1-            mpkg2 = lookupPackageId index pkgid2--        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-                 => PackageIndex pkg-                 -> [[pkg]]-dependencyCycles index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, packageId pkg, depends pkg)-                    | pkg <- allPackages index ]---- | 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-                => PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    PackageIdentifier -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)-  where-    graph = Array.listArray bounds $-            map (catMaybes . map pkgIdToVertex . depends) pkgs-    vertexToPkg vertex = pkgTable ! vertex-    pkgIdToVertex = binarySearch 0 topBound--    pkgTable   = Array.listArray bounds pkgs-    pkgIdTable = Array.listArray bounds (map packageId pkgs)-    pkgs = sortBy (comparing packageId) (allPackages index)-    topBound = length pkgs - 1-    bounds = (0, topBound)--    binarySearch a b key-      | a > b     = Nothing-      | otherwise = case compare key (pkgIdTable ! 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/ParseUtils.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.ParseUtils@@ -7,13 +9,41 @@ -- Parsing utilities. ----------------------------------------------------------------------------- -module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )+module Distribution.Client.ParseUtils (++    -- * Fields and field utilities+    FieldDescr(..),+    liftField,+    liftFields,+    filterFields,+    mapFieldNames,+    commandOptionToField,+    commandOptionsToFields,++    -- * Sections and utilities+    SectionDescr(..),+    liftSection,++    -- * Parsing and printing flat config+    parseFields,+    ppFields,+    ppSection,++    -- * Parsing and printing config with sections and subsections+    parseFieldsAndSections,+    ppFieldsAndSections,++    -- ** Top level of config files+    parseConfig,+    showConfig,+  )        where  import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), warning, lineNo )-import qualified Distribution.ParseUtils as ParseUtils-         ( Field(..) )+         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo+         , Field(..), liftField, readFieldsFlat )+import Distribution.Simple.Command+         ( OptionField, viewAsFieldDescr )  import Control.Monad    ( foldM ) import Text.PrettyPrint ( (<>), (<+>), ($+$) )@@ -21,18 +51,101 @@ import qualified Text.PrettyPrint as Disp          ( Doc, text, colon, vcat, empty, isEmpty, nest ) ---FIXME: replace this with something better-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a-parseFields fields = foldM setField++-------------------------+-- FieldDescr utilities+--++liftFields :: (b -> a)+           -> (a -> b -> b)+           -> [FieldDescr a]+           -> [FieldDescr b]+liftFields get set = map (liftField get set)+++-- | Given a collection of field descriptions, keep only a given list of them,+-- identified by name.+--+filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]+filterFields includeFields = filter ((`elem` includeFields) . fieldName)++-- | Apply a name mangling function to the field names of all the field+-- descriptions. The typical use case is to apply some prefix.+--+mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]+mapFieldNames mangleName =+    map (\descr -> descr { fieldName = mangleName (fieldName descr) })+++-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.+--+commandOptionToField :: OptionField a -> FieldDescr a+commandOptionToField = viewAsFieldDescr++-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.+--+commandOptionsToFields :: [OptionField a] -> [FieldDescr a]+commandOptionsToFields = map viewAsFieldDescr+++------------------------------------------+-- SectionDescr definition and utilities+--++-- | The description of a section in a config file. It can contain both+-- fields and optionally further subsections. See also 'FieldDescr'.+--+data SectionDescr a = forall b. SectionDescr {+       sectionName        :: String,+       sectionFields      :: [FieldDescr b],+       sectionSubsections :: [SectionDescr b],+       sectionGet         :: a -> [(String, b)],+       sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,+       sectionEmpty       :: b+     }++-- | To help construction of config file descriptions in a modular way it is+-- useful to define fields and sections on local types and then hoist them+-- into the parent types when combining them in bigger descriptions.+--+-- This is essentially a lens operation for 'SectionDescr' to help embedding+-- one inside another.+--+liftSection :: (b -> a)+            -> (a -> b -> b)+            -> SectionDescr a+            -> SectionDescr b+liftSection get' set' (SectionDescr name fields sections get set empty) =+    let sectionGet' = get . get'+        sectionSet' lineno param x y = do+          x' <- set lineno param x (get' y)+          return (set' x' y)+     in SectionDescr name fields sections sectionGet' sectionSet' empty+++-------------------------------------+-- Parsing and printing flat config+--++-- | Parse a bunch of semi-parsed 'Field's according to a set of field+-- descriptions. It accumulates the result on top of a given initial value.+--+-- This only covers the case of flat configuration without subsections. See+-- also 'parseFieldsAndSections'.+--+parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a+parseFields fieldDescrs =+    foldM setField   where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (ParseUtils.F line name value) =+    fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]++    setField accum (F line name value) =       case Map.lookup name fieldMap of         Just (FieldDescr _ _ set) -> set line value accum         Nothing -> do           warning $ "Unrecognized field " ++ name ++ " on line " ++ show line           return accum+     setField accum f = do       warning $ "Unrecognized stanza on line " ++ show (lineNo f)       return accum@@ -41,8 +154,9 @@ -- that also optionally print default values for empty fields as comments. -- ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-ppFields fields def cur = Disp.vcat [ ppField name (fmap getter def) (getter cur)-                                    | FieldDescr name getter _ <- fields]+ppFields fields def cur =+    Disp.vcat [ ppField name (fmap getter def) (getter cur)+              | FieldDescr name getter _ <- fields]  ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc ppField name mdef cur@@ -51,6 +165,11 @@                                 <> Disp.colon <+> def) mdef   | otherwise        = Disp.text name <> Disp.colon <+> cur +-- | Pretty print a section.+--+-- Since 'ppFields' does not cover subsections you can use this to add them.+-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.+-- ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc ppSection name arg fields def cur   | Disp.isEmpty fieldsDoc = Disp.empty@@ -60,3 +179,101 @@     fieldsDoc = ppFields fields def cur     argDoc | arg == "" = Disp.empty            | otherwise = Disp.text arg+++-----------------------------------------+-- Parsing and printing non-flat config+--++-- | Much like 'parseFields' but it also allows subsections. The permitted+-- subsections are given by a list of 'SectionDescr's.+--+parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a+                       -> [Field] -> ParseResult a+parseFieldsAndSections fieldDescrs sectionDescrs =+    foldM setField+  where+    fieldMap   = Map.fromList [ (fieldName   f, f) | f <- fieldDescrs   ]+    sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]++    setField a (F line name value) =+      case Map.lookup name fieldMap of+        Just (FieldDescr _ _ set) -> set line value a+        Nothing -> do+          warning $ "Unrecognized field '" ++ name+                 ++ "' on line " ++ show line+          return a++    setField a (Section line name param fields) =+      case Map.lookup name sectionMap of+        Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do+          b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields+          set line param b a+        Nothing -> do+          warning $ "Unrecognized section '" ++ name+                 ++ "' on line " ++ show line+          return a++    setField accum (block@IfBlock {}) = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo block)+      return accum++-- | Much like 'ppFields' but also pretty prints any subsections. Subsection+-- are only shown if they are non-empty.+--+-- Note that unlike 'ppFields', at present it does not support printing+-- default values. If needed, adding such support would be quite reasonable.+--+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+ppFieldsAndSections fieldDescrs sectionDescrs val =+    ppFields fieldDescrs Nothing val+      $+$+    Disp.vcat+      [ Disp.text "" $+$ sectionDoc+      | SectionDescr {+          sectionName, sectionGet,+          sectionFields, sectionSubsections+        } <- sectionDescrs+      , (param, x) <- sectionGet val+      , let sectionDoc = ppSectionAndSubsections+                           sectionName param+                           sectionFields sectionSubsections x+      , not (Disp.isEmpty sectionDoc)+      ]++-- | Unlike 'ppSection' which has to be called directly, this gets used via+-- 'ppFieldsAndSections' and so does not need to be exported.+--+ppSectionAndSubsections :: String -> String+                        -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+ppSectionAndSubsections name arg fields sections cur+  | Disp.isEmpty fieldsDoc = Disp.empty+  | otherwise              = Disp.text name <+> argDoc+                             $+$ (Disp.nest 2 fieldsDoc)+  where+    fieldsDoc = showConfig fields sections cur+    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg+++-----------------------------------------------+-- Top level config file parsing and printing+--++-- | Parse a string in the config file syntax into a value, based on a+-- description of the configuration file in terms of its fields and sections.+--+-- It accumulates the result on top of a given initial (typically empty) value.+--+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a+            -> String -> ParseResult a+parseConfig fieldDescrs sectionDescrs empty str =+      parseFieldsAndSections fieldDescrs sectionDescrs empty+  =<< readFieldsFlat str++-- | Render a value in the config file syntax, based on a description of the+-- configuration file in terms of its fields and sections.+--+showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+showConfig = ppFieldsAndSections+
+ Distribution/Client/PkgConfigDb.hs view
@@ -0,0 +1,146 @@+{-# 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 view
@@ -0,0 +1,289 @@+-- | 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
@@ -0,0 +1,1284 @@+{-# 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+          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+          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 $ 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 $+          setup replCommand replFlags replArgs++        -- Haddock phase+        whenHaddock $+          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 . show+                       --TODO: [nice to have] use displayException when available+++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+
+ Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,746 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable #-}++-- | Handling project configuration.+--+module Distribution.Client.ProjectConfig (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    PackageConfig(..),+    MapLast(..),+    MapMappend(..),++    -- * Project config files+    findProjectRoot,+    readProjectConfig,+    writeProjectLocalExtraConfig,+    writeProjectConfigFile,+    commandLineFlagsToProjectConfig,++    -- * Packages within projects+    ProjectPackageLocation(..),+    BadPackageLocation(..),+    BadPackageLocationMatch(..),+    findProjectPackages,+    readSourcePackage,++    -- * Resolving configuration+    lookupLocalPackageConfig,+    projectConfigWithBuilderRepoContext,+    projectConfigWithSolverRepoContext,+    SolverSettings(..),+    resolveSolverSettings,+    BuildTimeSettings(..),+    resolveBuildTimeSettings,++    -- * Checking configuration+    checkBadPerPackageCompilerPaths,+    BadPerPackageCompilerPaths(..)+  ) where++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.ProjectConfig.Legacy+import Distribution.Client.RebuildMonad+import Distribution.Client.Glob+         ( isTrivialFilePathGlob )++import Distribution.Client.Types+import Distribution.Client.DistDirLayout+         ( CabalDirLayout(..) )+import Distribution.Client.GlobalFlags+         ( RepoContext(..), withRepoContext' )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Config+         ( loadConfig, defaultConfigFile )++import Distribution.Package+         ( PackageName, PackageId, packageId, UnitId, Dependency )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( SourceRepo(..) )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo )+import Distribution.Simple.Program+         ( ConfiguredProgram(..) )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, flagToMaybe, flagToList+         , fromFlag, AllowNewer(..) )+import Distribution.Client.Setup+         ( defaultSolver, defaultMaxBackjumps, )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , toPathTemplate, substPathTemplate, initialPathTemplateEnv )+import Distribution.Simple.Utils+         ( die, warn )+import Distribution.Client.Utils+         ( determineNumJobs )+import Distribution.Utils.NubList+         ( fromNubList )+import Distribution.Verbosity+         ( Verbosity, verbose )+import Distribution.Text+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 qualified Data.Set as Set+import Distribution.Compat.Semigroup+import System.FilePath hiding (combine)+import System.Directory+import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+++----------------------------------------+-- Resolving configuration to settings+--++-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific+-- 'PackageName'. This returns the configuration that applies to all local+-- packages plus any package-specific configuration for this package.+--+lookupLocalPackageConfig :: (Semigroup a, Monoid a)+                         => (PackageConfig -> a)+                         -> ProjectConfig+                         -> PackageName -> a+lookupLocalPackageConfig field ProjectConfig {+                           projectConfigLocalPackages,+                           projectConfigSpecificPackage+                         } pkgname =+    field projectConfigLocalPackages+ <> maybe mempty field+          (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))+++-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.+--+projectConfigWithBuilderRepoContext :: Verbosity+                                    -> BuildTimeSettings+                                    -> (RepoContext -> IO a) -> IO a+projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =+    withRepoContext'+      verbosity+      buildSettingRemoteRepos+      buildSettingLocalRepos+      buildSettingCacheDir+      buildSettingHttpTransport+      (Just buildSettingIgnoreExpiry)+++-- | Use a 'RepoContext', but only for the solver. The solver does not use the+-- full facilities of the 'RepoContext' so we can get away with making one+-- that doesn't have an http transport. And that avoids having to have access+-- to the 'BuildTimeSettings'+--+projectConfigWithSolverRepoContext :: Verbosity+                                   -> FilePath+                                   -> ProjectConfigShared+                                   -> ProjectConfigBuildOnly+                                   -> (RepoContext -> IO a) -> IO a+projectConfigWithSolverRepoContext verbosity downloadCacheRootDir+                                   ProjectConfigShared{..}+                                   ProjectConfigBuildOnly{..} =+    withRepoContext'+      verbosity+      (fromNubList projectConfigRemoteRepos)+      (fromNubList projectConfigLocalRepos)+      downloadCacheRootDir+      (flagToMaybe projectConfigHttpTransport)+      (flagToMaybe projectConfigIgnoreExpiry)+++-- | Resolve the project configuration, with all its optional fields, into+-- 'SolverSettings' with no optional fields (by applying defaults).+--+resolveSolverSettings :: ProjectConfig -> SolverSettings+resolveSolverSettings ProjectConfig{+                        projectConfigShared,+                        projectConfigLocalPackages,+                        projectConfigSpecificPackage+                      } =+    SolverSettings {..}+  where+    --TODO: [required eventually] some of these settings need validation, e.g.+    -- the flag assignments need checking.+    solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos+    solverSettingLocalRepos        = fromNubList projectConfigLocalRepos+    solverSettingConstraints       = projectConfigConstraints+    solverSettingPreferences       = projectConfigPreferences+    solverSettingFlagAssignment    = packageConfigFlagAssignment projectConfigLocalPackages+    solverSettingFlagAssignments   = fmap packageConfigFlagAssignment+                                          (getMapMappend projectConfigSpecificPackage)+    solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion+    solverSettingSolver            = fromFlag projectConfigSolver+    solverSettingAllowNewer        = fromJust projectConfigAllowNewer+    solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of+                                       n | n < 0     -> Nothing+                                         | otherwise -> Just n+    solverSettingReorderGoals      = fromFlag projectConfigReorderGoals+    solverSettingStrongFlags       = fromFlag projectConfigStrongFlags+  --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals+  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs+  --solverSettingReinstall         = fromFlag projectConfigReinstall+  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls+  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall+  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps++    ProjectConfigShared {..} = defaults <> projectConfigShared++    defaults = mempty {+       projectConfigSolver            = Flag defaultSolver,+       projectConfigAllowNewer        = Just AllowNewerNone,+       projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,+       projectConfigReorderGoals      = Flag False,+       projectConfigStrongFlags       = Flag False+     --projectConfigIndependentGoals  = Flag False,+     --projectConfigShadowPkgs        = Flag False,+     --projectConfigReinstall         = Flag False,+     --projectConfigAvoidReinstalls   = Flag False,+     --projectConfigOverrideReinstall = Flag False,+     --projectConfigUpgradeDeps       = Flag False+    }+++-- | Resolve the project configuration, with all its optional fields, into+-- 'BuildTimeSettings' with no optional fields (by applying defaults).+--+resolveBuildTimeSettings :: Verbosity+                         -> CabalDirLayout+                         -> ProjectConfigShared+                         -> ProjectConfigBuildOnly+                         -> ProjectConfigBuildOnly+                         -> BuildTimeSettings+resolveBuildTimeSettings verbosity+                         CabalDirLayout {+                           cabalLogsDirectory,+                           cabalPackageCacheDirectory+                         }+                         ProjectConfigShared {+                           projectConfigRemoteRepos,+                           projectConfigLocalRepos+                         }+                         fromProjectFile+                         fromCommandLine =+    BuildTimeSettings {..}+  where+    buildSettingDryRun        = fromFlag    projectConfigDryRun+    buildSettingOnlyDeps      = fromFlag    projectConfigOnlyDeps+    buildSettingSummaryFile   = fromNubList projectConfigSummaryFile+    --buildSettingLogFile       -- defined below, more complicated +    --buildSettingLogVerbosity  -- defined below, more complicated+    buildSettingBuildReports  = fromFlag    projectConfigBuildReports+    buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir+    buildSettingOneShot       = fromFlag    projectConfigOneShot+    buildSettingNumJobs       = determineNumJobs projectConfigNumJobs+    buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode+    buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles+    buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos+    buildSettingLocalRepos    = fromNubList projectConfigLocalRepos+    buildSettingCacheDir      = cabalPackageCacheDirectory+    buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport+    buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry+    buildSettingReportPlanningFailure+                              = fromFlag projectConfigReportPlanningFailure+    buildSettingRootCmd       = flagToMaybe projectConfigRootCmd++    ProjectConfigBuildOnly{..} = defaults+                              <> fromProjectFile+                              <> fromCommandLine++    defaults = mempty {+      projectConfigDryRun                = toFlag False,+      projectConfigOnlyDeps              = toFlag False,+      projectConfigBuildReports          = toFlag NoReports,+      projectConfigReportPlanningFailure = toFlag False,+      projectConfigOneShot               = toFlag False,+      projectConfigOfflineMode           = toFlag False,+      projectConfigKeepTempFiles         = toFlag False,+      projectConfigIgnoreExpiry          = toFlag False+    }++    -- The logging logic: what log file to use and what verbosity.+    --+    -- If the user has specified --remote-build-reporting=detailed, use the+    -- default log file location. If the --build-log option is set, use the+    -- provided location. Otherwise don't use logging, unless building in+    -- parallel (in which case the default location is used).+    --+    buildSettingLogFile :: Maybe (Compiler -> Platform+                               -> PackageId -> UnitId -> FilePath)+    buildSettingLogFile+      | useDefaultTemplate = Just (substLogFileName defaultTemplate)+      | otherwise          = fmap  substLogFileName givenTemplate++    defaultTemplate = toPathTemplate $+                        cabalLogsDirectory </> "$pkgid" <.> "log"+    givenTemplate   = flagToMaybe projectConfigLogFile++    useDefaultTemplate+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = False+      | isParallelBuild                             = True+      | otherwise                                   = False++    isParallelBuild = buildSettingNumJobs >= 2++    substLogFileName :: PathTemplate+                     -> Compiler -> Platform+                     -> PackageId -> UnitId -> FilePath+    substLogFileName template compiler platform pkgid uid =+        fromPathTemplate (substPathTemplate env template)+      where+        env = initialPathTemplateEnv+                pkgid uid (compilerInfo compiler) platform++    -- If the user has specified --remote-build-reporting=detailed or+    -- --build-log, use more verbose logging.+    --+    buildSettingLogVerbosity+      | overrideVerbosity = max verbose verbosity+      | otherwise         = verbosity++    overrideVerbosity+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = True+      | isParallelBuild                             = False+      | otherwise                                   = False+++---------------------------------------------+-- Reading and writing project config files+--++-- | Find the root of this project.+--+-- Searches for an explicit @cabal.project@ file, in the current directory or+-- parent directories. If no project file is found then the current dir is the+-- project root (and the project will use an implicit config).+--+findProjectRoot :: IO FilePath+findProjectRoot = do++    curdir  <- getCurrentDirectory+    homedir <- getHomeDirectory++    -- 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")+          if exists+            then return dir       -- explicit project root+            else probe (takeDirectory dir)++    probe curdir+   --TODO: [nice to have] add compat support for old style sandboxes+++-- | 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)+++-- | 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+  usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile+  if usesExplicitProjectRoot+    then do+      monitorFiles [monitorFileHashed projectFile]+      liftIO readProjectFile+    else do+      monitorFiles [monitorNonExistentFile projectFile]+      return defaultImplicitProjectConfig++  where+    projectFile = projectRootDir </> "cabal.project"+    readProjectFile =+          reportParseResult verbosity "project file" projectFile+        . parseProjectConfig+      =<< readFile projectFile++    defaultImplicitProjectConfig :: ProjectConfig+    defaultImplicitProjectConfig =+      mempty {+        -- We expect a package in the current directory.+        projectPackages         = [ "./*.cabal" ],++        -- This is to automatically pick up deps that we unpack locally.+        projectPackagesOptional = [ "./*/*.cabal" ]+      }+++-- | Reads a @cabal.project.extra@ 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]+              return mempty+  where+    projectExtraConfigFile = projectRootDir </> "cabal.project.local"++    readProjectExtraConfigFile =+          reportParseResult verbosity "project local configuration file"+                            projectExtraConfigFile+        . parseProjectConfig+      =<< readFile projectExtraConfigFile+++-- | Parse the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of parsers for legacy+-- configuration types, plus a conversion.+--+parseProjectConfig :: String -> ParseResult ProjectConfig+parseProjectConfig content =+    convertLegacyProjectConfig <$>+      parseLegacyProjectConfig content+++-- | Render the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of a pretty printer for the+-- legacy configuration types, plus a conversion.+--+showProjectConfig :: ProjectConfig -> String+showProjectConfig =+    showLegacyProjectConfig . convertToLegacyProjectConfig+++-- | Write a @cabal.project.extra@ file in the given project root dir.+--+writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO ()+writeProjectLocalExtraConfig projectRootDir =+    writeProjectConfigFile projectExtraConfigFile+  where+    projectExtraConfigFile = projectRootDir </> "cabal.project.local"+++-- | Write in the @cabal.project@ format to the given file.+--+writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()+writeProjectConfigFile file =+    writeFile file . showProjectConfig+++-- | Read the user's @~/.cabal/config@ file.+--+readGlobalConfig :: Verbosity -> Rebuild ProjectConfig+readGlobalConfig verbosity = do+    config     <- liftIO (loadConfig verbosity mempty)+    configFile <- liftIO defaultConfigFile+    monitorFiles [monitorFileHashed configFile]+    return (convertLegacyGlobalConfig config)+    --TODO: do this properly, there's several possible locations+    -- and env vars, and flags for selecting the global config+++reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a+reportParseResult verbosity _filetype filename (ParseOk warnings x) = do+    unless (null warnings) $+      let msg = unlines (map (showPWarning filename) warnings)+       in warn verbosity msg+    return x+reportParseResult _verbosity filetype filename (ParseFailed err) =+    let (line, msg) = locatedErrorMsg err+     in die $ "Error parsing " ++ filetype ++ " " ++ filename+           ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+++---------------------------------------------+-- Reading packages in the project+--++-- | The location of a package as part of a project. Local file paths are+-- either absolute (if the user specified it as such) or they are relative+-- to the project root.+--+data ProjectPackageLocation =+     ProjectPackageLocalCabalFile FilePath+   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file+   | ProjectPackageLocalTarball   FilePath+   | ProjectPackageRemoteTarball  URI+   | ProjectPackageRemoteRepo     SourceRepo+   | ProjectPackageNamed          Dependency+  deriving Show+++-- | Exception thrown by 'findProjectPackages'.+--+newtype BadPackageLocations = BadPackageLocations [BadPackageLocation]+  deriving (Show, Typeable)++instance Exception BadPackageLocations+--TODO: [required eventually] displayException for nice rendering+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++data BadPackageLocation+   = BadPackageLocationFile    BadPackageLocationMatch+   | BadLocGlobEmptyMatch      String+   | BadLocGlobBadMatches      String [BadPackageLocationMatch]+   | BadLocUnexpectedUriScheme String+   | BadLocUnrecognisedUri     String+   | BadLocUnrecognised        String+  deriving Show++data BadPackageLocationMatch+   = BadLocUnexpectedFile      String+   | BadLocNonexistantFile     String+   | BadLocDirNoCabalFile      String+   | BadLocDirManyCabalFiles   String+  deriving Show+++-- | Given the project config, +--+-- Throws 'BadPackageLocations'.+--+findProjectPackages :: FilePath -> ProjectConfig+                    -> Rebuild [ProjectPackageLocation]+findProjectPackages projectRootDir ProjectConfig{..} = do++    requiredPkgs <- findPackageLocations True    projectPackages+    optionalPkgs <- findPackageLocations False   projectPackagesOptional+    let repoPkgs  = map ProjectPackageRemoteRepo projectPackagesRepo+        namedPkgs = map ProjectPackageNamed      projectPackagesNamed++    return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])+  where+    findPackageLocations required pkglocstr = do+      (problems, pkglocs) <-+        partitionEithers <$> mapM (findPackageLocation required) pkglocstr+      unless (null problems) $+        liftIO $ throwIO $ BadPackageLocations problems+      return (concat pkglocs)+++    findPackageLocation :: Bool -> String+                        -> Rebuild (Either BadPackageLocation+                                          [ProjectPackageLocation])+    findPackageLocation _required@True pkglocstr =+      -- strategy: try first as a file:// or http(s):// URL.+      -- then as a file glob (usually encompassing single file)+      -- finally as a single file, for files that fail to parse as globs+                    checkIsUriPackage pkglocstr+      `mplusMaybeT` checkIsFileGlobPackage pkglocstr+      `mplusMaybeT` checkIsSingleFilePackage pkglocstr+      >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return+++    findPackageLocation _required@False pkglocstr = do+      -- just globs for optional case+      res <- checkIsFileGlobPackage pkglocstr+      case res of+        Nothing              -> return (Left (BadLocUnrecognised pkglocstr))+        Just (Left _)        -> return (Right []) -- it's optional+        Just (Right pkglocs) -> return (Right pkglocs)+++    checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage+      :: String -> Rebuild (Maybe (Either BadPackageLocation+                                         [ProjectPackageLocation]))+    checkIsUriPackage pkglocstr =+      return $!+      case parseAbsoluteURI pkglocstr of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host }+          }+          | recognisedScheme && not (null host) ->+            Just (Right [ProjectPackageRemoteTarball uri])++          | not recognisedScheme && not (null host) ->+            Just (Left (BadLocUnexpectedUriScheme pkglocstr))++          | recognisedScheme && null host ->+            Just (Left (BadLocUnrecognisedUri pkglocstr))+          where+            recognisedScheme = scheme == "http:" || scheme == "https:"+                            || scheme == "file:"++        _ -> Nothing+++    checkIsFileGlobPackage pkglocstr =+      case simpleParse pkglocstr of+        Nothing   -> return Nothing+        Just glob -> liftM Just $ do+          matches <- matchFileGlob glob+          case matches of+            [] | isJust (isTrivialFilePathGlob glob)+               -> return (Left (BadPackageLocationFile +                                  (BadLocNonexistantFile pkglocstr)))++            [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))++            _  -> do+              (failures, pkglocs) <- partitionEithers <$>+                                     mapM checkFilePackageMatch matches+              if null pkglocs+                then return (Left (BadLocGlobBadMatches pkglocstr failures))+                else return (Right pkglocs)+++    checkIsSingleFilePackage pkglocstr = do+      let filename = projectRootDir </> pkglocstr+      isFile <- liftIO $ doesFileExist filename+      isDir  <- liftIO $ doesDirectoryExist filename+      if isFile || isDir+        then checkFilePackageMatch pkglocstr+         >>= either (return . Just . Left  . BadPackageLocationFile)+                    (return . Just . Right . (\x->[x]))+        else return Nothing+++    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch+                                                       ProjectPackageLocation)+    checkFilePackageMatch pkglocstr = do+      -- The pkglocstr may be absolute or may be relative to the project root.+      -- Either way, </> does the right thing here. We return relative paths if+      -- they were relative in the first place.+      let abspath = projectRootDir </> pkglocstr+      isDir  <- liftIO $ doesDirectoryExist abspath+      parentDirExists <- case takeDirectory abspath of+                           []  -> return False+                           dir -> liftIO $ doesDirectoryExist dir+      case () of+        _ | isDir+         -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)+               case matches of+                 [cabalFile]+                     -> return (Right (ProjectPackageLocalDirectory+                                         pkglocstr cabalFile))+                 []  -> return (Left (BadLocDirNoCabalFile pkglocstr))+                 _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))++          | extensionIsTarGz pkglocstr+         -> return (Right (ProjectPackageLocalTarball pkglocstr))++          | takeExtension pkglocstr == ".cabal"+         -> return (Right (ProjectPackageLocalCabalFile pkglocstr))++          | parentDirExists+         -> return (Left (BadLocNonexistantFile pkglocstr))++          | otherwise+         -> return (Left (BadLocUnexpectedFile pkglocstr))+++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"+++-- | A glob to find all the cabal files in a directory.+--+-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.+-- The directory part can be either absolute or relative.+--+globStarDotCabal :: FilePath -> FilePathGlob+globStarDotCabal dir =+    FilePathGlob+      (if isAbsolute dir then FilePathRoot root else FilePathRelative)+      (foldr (\d -> GlobDir [Literal d])+             (GlobFile [WildCard, Literal ".cabal"]) dirComponents)+  where+    (root, dirComponents) = fmap splitDirectories (splitDrive dir)+++--TODO: [code cleanup] use sufficiently recent transformers package+mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+mplusMaybeT ma mb = do+  mx <- ma+  case mx of+    Nothing -> mb+    Just x  -> return (Just x)+++-- | Read the @.cabal@ file of the given package.+--+-- Note here is where we convert from project-root relative paths to absolute+-- paths.+--+readSourcePackage :: Verbosity -> ProjectPackageLocation+                  -> Rebuild SourcePackage+readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =+    readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile)+  where+    dir = takeDirectory cabalFile++readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do+    monitorFiles [monitorFileHashed cabalFile]+    root <- askRoot+    pkgdesc <- liftIO $ readPackageDescription verbosity (root </> cabalFile)+    return SourcePackage {+      packageInfoId        = packageId pkgdesc,+      packageDescription   = pkgdesc,+      packageSource        = LocalUnpackedPackage (root </> dir),+      packageDescrOverride = Nothing+    }+readSourcePackage _verbosity _ =+    fail $ "TODO: add support for fetching and reading local tarballs, remote "+        ++ "tarballs, remote repos and passing named packages through"+++---------------------------------------------+-- Checking configuration sanity+--++data BadPerPackageCompilerPaths+   = BadPerPackageCompilerPaths [(PackageName, String)]+  deriving (Show, Typeable)++instance Exception BadPerPackageCompilerPaths+--TODO: [required eventually] displayException for nice rendering+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++-- | The project configuration is not allowed to specify program locations for+-- programs used by the compiler as these have to be the same for each set of+-- packages.+--+-- We cannot check this until we know which programs the compiler uses, which+-- in principle is not until we've configured the compiler.+--+-- Throws 'BadPerPackageCompilerPaths'+--+checkBadPerPackageCompilerPaths :: [ConfiguredProgram]+                                -> Map PackageName PackageConfig+                                -> IO ()+checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =+    case [ (pkgname, progname)+         | let compProgNames = Set.fromList (map programId compilerPrograms)+         ,  (pkgname, pkgconf) <- Map.toList packagesConfig+         , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))+         , progname `Set.member` compProgNames ] of+      [] -> return ()+      ps -> throwIO (BadPerPackageCompilerPaths ps)+
+ Distribution/Client/ProjectConfig/Legacy.hs view
@@ -0,0 +1,1259 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveGeneric #-}++-- | Project configuration, implementation in terms of legacy types.+--+module Distribution.Client.ProjectConfig.Legacy (++    -- * Project config in terms of legacy types+    LegacyProjectConfig,+    parseLegacyProjectConfig,+    showLegacyProjectConfig,++    -- * Conversion to and from legacy config types+    commandLineFlagsToProjectConfig,+    convertLegacyProjectConfig,+    convertLegacyGlobalConfig,+    convertToLegacyProjectConfig,++    -- * Internals, just for tests+    parsePackageLocationTokenQ,+    renderPackageLocationToken,+  ) where++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.Types+         ( RemoteRepo(..), emptyRemoteRepo )+import Distribution.Client.Dependency.Types+         ( ConstraintSource(..) )+import Distribution.Client.Config+         ( SavedConfig(..), remoteRepoFields )++import Distribution.Package+import Distribution.PackageDescription+         ( SourceRepo(..), RepoKind(..) )+import Distribution.PackageDescription.Parse+         ( sourceRepoFieldDescrs )+import Distribution.Simple.Compiler+         ( OptimisationLevel(..), DebugInfoLevel(..) )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, fromFlagOrDefault+         , ConfigFlags(..), configureOptions+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags+         , programConfigurationPaths', splitArgs+         , AllowNewer(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , InstallFlags(..), installOptions, defaultInstallFlags )+import Distribution.Simple.Program+         ( programName, knownPrograms )+import Distribution.Simple.Program.Db+         ( ProgramDb, defaultProgramDb )+import Distribution.Client.Targets+         ( dispFlagAssignment, parseFlagAssignment )+import Distribution.Simple.Utils+         ( lowercase )+import Distribution.Utils.NubList+         ( toNubList, fromNubList, overNubList )+import Distribution.Simple.LocalBuildInfo+         ( toPathTemplate, fromPathTemplate )++import Distribution.Text+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( ReadP, (+++), (<++) )+import qualified Text.Read as Read+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( Doc, ($+$) )+import qualified Distribution.ParseUtils as ParseUtils (field)+import Distribution.ParseUtils+         ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning+         , simpleField, commaNewLineListField+         , showToken )+import Distribution.Client.ParseUtils+import Distribution.Simple.Command+         ( 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+--++-- | We already have parsers\/pretty-printers for almost all the fields in the+-- project config file, but they're in terms of the types used for the command+-- line flags for Setup.hs or cabal commands. We don't want to redefine them+-- all, at least not yet so for the moment we use the parsers at the old types+-- and use conversion functions.+--+-- Ultimately if\/when this project-based approach becomes the default then we+-- can redefine the parsers directly for the new types.+--+data LegacyProjectConfig = LegacyProjectConfig {+       legacyPackages          :: [String],+       legacyPackagesOptional  :: [String],+       legacyPackagesRepo      :: [SourceRepo],+       legacyPackagesNamed     :: [Dependency],++       legacySharedConfig      :: LegacySharedConfig,+       legacyLocalConfig       :: LegacyPackageConfig,+       legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig+     } deriving Generic++instance Monoid LegacyProjectConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyProjectConfig where+  (<>) = gmappend++data LegacyPackageConfig = LegacyPackageConfig {+       legacyConfigureFlags    :: ConfigFlags,+       legacyInstallPkgFlags   :: InstallFlags,+       legacyHaddockFlags      :: HaddockFlags+     } deriving Generic++instance Monoid LegacyPackageConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyPackageConfig where+  (<>) = gmappend++data LegacySharedConfig = LegacySharedConfig {+       legacyGlobalFlags       :: GlobalFlags,+       legacyConfigureShFlags  :: ConfigFlags,+       legacyConfigureExFlags  :: ConfigExFlags,+       legacyInstallFlags      :: InstallFlags+     } deriving Generic++instance Monoid LegacySharedConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacySharedConfig where+  (<>) = gmappend+++------------------------------------------------------------------+-- Converting from and to the legacy types+--++-- | Convert configuration from the @cabal configure@ or @cabal build@ command+-- line into a 'ProjectConfig' value that can combined with configuration from+-- other sources.+--+-- At the moment this uses the legacy command line flag types. See+-- 'LegacyProjectConfig' for an explanation.+--+commandLineFlagsToProjectConfig :: GlobalFlags+                                -> ConfigFlags  -> ConfigExFlags+                                -> InstallFlags -> HaddockFlags+                                -> ProjectConfig+commandLineFlagsToProjectConfig globalFlags configFlags configExFlags+                                installFlags haddockFlags =+    mempty {+      projectConfigBuildOnly     = convertLegacyBuildOnlyFlags+                                     globalFlags configFlags+                                     installFlags haddockFlags,+      projectConfigShared        = convertLegacyAllPackageFlags+                                     globalFlags configFlags+                                     configExFlags installFlags,+      projectConfigLocalPackages = convertLegacyPerPackageFlags+                                     configFlags installFlags haddockFlags+    }+++-- | Convert from the types currently used for the user-wide @~/.cabal/config@+-- file into the 'ProjectConfig' type.+--+-- Only a subset of the 'ProjectConfig' can be represented in the user-wide+-- config. In particular it does not include packages that are in the project,+-- and it also doesn't support package-specific configuration (only+-- configuration that applies to all packages).+--+convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig+convertLegacyGlobalConfig+    SavedConfig {+      savedGlobalFlags       = globalFlags,+      savedInstallFlags      = installFlags,+      savedConfigureFlags    = configFlags,+      savedConfigureExFlags  = configExFlags,+      savedUserInstallDirs   = _,+      savedGlobalInstallDirs = _,+      savedUploadFlags       = _,+      savedReportFlags       = _,+      savedHaddockFlags      = haddockFlags+    } =+    mempty {+      projectConfigShared        = configAllPackages,+      projectConfigLocalPackages = configLocalPackages,+      projectConfigBuildOnly     = configBuildOnly+    }+  where+    --TODO: [code cleanup] eliminate use of default*Flags here and specify the+    -- defaults in the various resolve functions in terms of the new types.+    configExFlags' = defaultConfigExFlags <> configExFlags+    installFlags'  = defaultInstallFlags  <> installFlags+    haddockFlags'  = defaultHaddockFlags  <> haddockFlags++    configLocalPackages = convertLegacyPerPackageFlags+                            configFlags installFlags' haddockFlags'+    configAllPackages   = convertLegacyAllPackageFlags+                            globalFlags configFlags+                            configExFlags' installFlags'+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configFlags+                            installFlags' haddockFlags'+++-- | Convert the project config from the legacy types to the 'ProjectConfig'+-- and associated types. See 'LegacyProjectConfig' for an explanation of the+-- approach.+--+convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig+convertLegacyProjectConfig+  LegacyProjectConfig {+    legacyPackages,+    legacyPackagesOptional,+    legacyPackagesRepo,+    legacyPackagesNamed,+    legacySharedConfig = LegacySharedConfig globalFlags configShFlags+                                            configExFlags installSharedFlags,+    legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags+                                             haddockFlags,+    legacySpecificConfig+  } =++    ProjectConfig {+      projectPackages              = legacyPackages,+      projectPackagesOptional      = legacyPackagesOptional,+      projectPackagesRepo          = legacyPackagesRepo,+      projectPackagesNamed         = legacyPackagesNamed,++      projectConfigBuildOnly       = configBuildOnly,+      projectConfigShared          = configAllPackages,+      projectConfigLocalPackages   = configLocalPackages,+      projectConfigSpecificPackage = fmap perPackage legacySpecificConfig+    }+  where+    configLocalPackages = convertLegacyPerPackageFlags+                            configFlags installPerPkgFlags haddockFlags+    configAllPackages   = convertLegacyAllPackageFlags+                            globalFlags (configFlags <> configShFlags)+                            configExFlags installSharedFlags+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configShFlags+                            installSharedFlags haddockFlags++    perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags+                                    perPkgHaddockFlags) =+      convertLegacyPerPackageFlags+        perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags+++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigShared' subset of the 'ProjectConfig'.+--+convertLegacyAllPackageFlags :: GlobalFlags -> ConfigFlags+                             -> ConfigExFlags -> InstallFlags+                             -> ProjectConfigShared+convertLegacyAllPackageFlags globalFlags configFlags+                             configExFlags installFlags =+    ProjectConfigShared{..}+  where+    GlobalFlags {+      globalConfigFile        = _, -- TODO: [required feature]+      globalSandboxConfigFile = _, -- ??+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalLocalRepos        = projectConfigLocalRepos+    } = globalFlags++    ConfigFlags {+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg,+    --configInstallDirs         = projectConfigInstallDirs,+    --configUserInstall         = projectConfigUserInstall,+    --configPackageDBs          = projectConfigPackageDBs,+      configAllowNewer          = projectConfigAllowNewer+    } = configFlags++    ConfigExFlags {+      configCabalVersion        = projectConfigCabalVersion,+      configExConstraints       = projectConfigConstraints,+      configPreferences         = projectConfigPreferences,+      configSolver              = projectConfigSolver+    } = configExFlags++    InstallFlags {+      installHaddockIndex       = projectConfigHaddockIndex,+    --installReinstall          = projectConfigReinstall,+    --installAvoidReinstalls    = projectConfigAvoidReinstalls,+    --installOverrideReinstall  = projectConfigOverrideReinstall,+      installMaxBackjumps       = projectConfigMaxBackjumps,+    --installUpgradeDeps        = projectConfigUpgradeDeps,+      installReorderGoals       = projectConfigReorderGoals,+    --installIndependentGoals   = projectConfigIndependentGoals,+    --installShadowPkgs         = projectConfigShadowPkgs,+      installStrongFlags        = projectConfigStrongFlags+    } = installFlags++++-- | Helper used by other conversion functions that returns the+-- 'PackageConfig' subset of the 'ProjectConfig'.+--+convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags+                             -> PackageConfig+convertLegacyPerPackageFlags configFlags installFlags haddockFlags =+    PackageConfig{..}+  where+    ConfigFlags {+      configProgramPaths,+      configProgramArgs,+      configProgramPathExtra    = packageConfigProgramPathExtra,+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configDynExe              = packageConfigDynExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configConfigurationsFlags = packageConfigFlagAssignment,+      configTests               = packageConfigTests,+      configBenchmarks          = packageConfigBenchmarks,+      configCoverage            = coverage,+      configLibCoverage         = libcoverage, --deprecated+      configDebugInfo           = packageConfigDebugInfo,+      configRelocatable         = packageConfigRelocatable+    } = configFlags+    packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)+    packageConfigProgramArgs    = MapMappend (Map.fromList configProgramArgs)++    packageConfigCoverage       = coverage <> libcoverage+    --TODO: defer this merging to the resolve phase++    InstallFlags {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    } = installFlags++    HaddockFlags {+      haddockHoogle             = packageConfigHaddockHoogle,+      haddockHtml               = packageConfigHaddockHtml,+      haddockHtmlLocation       = packageConfigHaddockHtmlLocation,+      haddockExecutables        = packageConfigHaddockExecutables,+      haddockTestSuites         = packageConfigHaddockTestSuites,+      haddockBenchmarks         = packageConfigHaddockBenchmarks,+      haddockInternal           = packageConfigHaddockInternal,+      haddockCss                = packageConfigHaddockCss,+      haddockHscolour           = packageConfigHaddockHscolour,+      haddockHscolourCss        = packageConfigHaddockHscolourCss,+      haddockContents           = packageConfigHaddockContents+    } = haddockFlags++++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.+--+convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags+                            -> InstallFlags -> HaddockFlags+                            -> ProjectConfigBuildOnly+convertLegacyBuildOnlyFlags globalFlags configFlags+                              installFlags haddockFlags =+    ProjectConfigBuildOnly{..}+  where+    GlobalFlags {+      globalCacheDir          = projectConfigCacheDir,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = projectConfigWorldFile,+      globalHttpTransport     = projectConfigHttpTransport,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry+    } = globalFlags++    ConfigFlags {+      configVerbosity           = projectConfigVerbosity+    } = configFlags++    InstallFlags {+      installDryRun             = projectConfigDryRun,+      installOnly               = _,+      installOnlyDeps           = projectConfigOnlyDeps,+      installRootCmd            = projectConfigRootCmd,+      installSummaryFile        = projectConfigSummaryFile,+      installLogFile            = projectConfigLogFile,+      installBuildReports       = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir      = projectConfigSymlinkBinDir,+      installOneShot            = projectConfigOneShot,+      installNumJobs            = projectConfigNumJobs,+      installOfflineMode        = projectConfigOfflineMode+    } = installFlags++    HaddockFlags {+      haddockKeepTempFiles      = projectConfigKeepTempFiles --TODO: this ought to live elsewhere+    } = haddockFlags+++convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig+convertToLegacyProjectConfig+    projectConfig@ProjectConfig {+      projectPackages,+      projectPackagesOptional,+      projectPackagesRepo,+      projectPackagesNamed,+      projectConfigLocalPackages,+      projectConfigSpecificPackage+    } =+    LegacyProjectConfig {+      legacyPackages         = projectPackages,+      legacyPackagesOptional = projectPackagesOptional,+      legacyPackagesRepo     = projectPackagesRepo,+      legacyPackagesNamed    = projectPackagesNamed,+      legacySharedConfig     = convertToLegacySharedConfig projectConfig,+      legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig+                            <> convertToLegacyPerPackageConfig+                                 projectConfigLocalPackages,+      legacySpecificConfig   = fmap convertToLegacyPerPackageConfig+                                    projectConfigSpecificPackage+    }++convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig+convertToLegacySharedConfig+    ProjectConfig {+      projectConfigBuildOnly     = ProjectConfigBuildOnly {..},+      projectConfigShared        = ProjectConfigShared {..}+    } =++    LegacySharedConfig {+      legacyGlobalFlags      = globalFlags,+      legacyConfigureShFlags = configFlags,+      legacyConfigureExFlags = configExFlags,+      legacyInstallFlags     = installFlags+    }+  where+    globalFlags = GlobalFlags {+      globalVersion           = mempty,+      globalNumericVersion    = mempty,+      globalConfigFile        = mempty,+      globalSandboxConfigFile = mempty,+      globalConstraintsFile   = mempty,+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalCacheDir          = projectConfigCacheDir,+      globalLocalRepos        = projectConfigLocalRepos,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = projectConfigWorldFile,+      globalRequireSandbox    = mempty,+      globalIgnoreSandbox     = mempty,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry,+      globalHttpTransport     = projectConfigHttpTransport+    }++    configFlags = mempty {+      configVerbosity     = projectConfigVerbosity,+      configAllowNewer    = projectConfigAllowNewer+    }++    configExFlags = ConfigExFlags {+      configCabalVersion  = projectConfigCabalVersion,+      configExConstraints = projectConfigConstraints,+      configPreferences   = projectConfigPreferences,+      configSolver        = projectConfigSolver+    }++    installFlags = InstallFlags {+      installDocumentation     = mempty,+      installHaddockIndex      = projectConfigHaddockIndex,+      installDryRun            = projectConfigDryRun,+      installReinstall         = mempty, --projectConfigReinstall,+      installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,+      installOverrideReinstall = mempty, --projectConfigOverrideReinstall,+      installMaxBackjumps      = projectConfigMaxBackjumps,+      installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,+      installReorderGoals      = projectConfigReorderGoals,+      installIndependentGoals  = mempty, --projectConfigIndependentGoals,+      installShadowPkgs        = mempty, --projectConfigShadowPkgs,+      installStrongFlags       = projectConfigStrongFlags,+      installOnly              = mempty,+      installOnlyDeps          = projectConfigOnlyDeps,+      installRootCmd           = projectConfigRootCmd,+      installSummaryFile       = projectConfigSummaryFile,+      installLogFile           = projectConfigLogFile,+      installBuildReports      = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir     = projectConfigSymlinkBinDir,+      installOneShot           = projectConfigOneShot,+      installNumJobs           = projectConfigNumJobs,+      installRunTests          = mempty,+      installOfflineMode       = projectConfigOfflineMode+    }+++convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig+convertToLegacyAllPackageConfig+    ProjectConfig {+      projectConfigBuildOnly = ProjectConfigBuildOnly {..},+      projectConfigShared    = ProjectConfigShared {..}+    } =++    LegacyPackageConfig {+      legacyConfigureFlags = configFlags,+      legacyInstallPkgFlags= mempty,+      legacyHaddockFlags   = haddockFlags+    }+  where+    configFlags = ConfigFlags {+      configPrograms_           = mempty,+      configProgramPaths        = mempty,+      configProgramArgs         = mempty,+      configProgramPathExtra    = mempty,+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg,+      configVanillaLib          = mempty,+      configProfLib             = mempty,+      configSharedLib           = mempty,+      configDynExe              = mempty,+      configProfExe             = mempty,+      configProf                = mempty,+      configProfDetail          = mempty,+      configProfLibDetail       = mempty,+      configConfigureArgs       = mempty,+      configOptimization        = mempty,+      configProgPrefix          = mempty,+      configProgSuffix          = mempty,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty, --projectConfigUserInstall,+      configPackageDBs          = mempty, --projectConfigPackageDBs,+      configGHCiLib             = mempty,+      configSplitObjs           = mempty,+      configStripExes           = mempty,+      configStripLibs           = mempty,+      configExtraLibDirs        = mempty,+      configExtraFrameworkDirs  = mempty,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = mempty,+      configIPID                = mempty,+      configConfigurationsFlags = mempty,+      configTests               = mempty,+      configCoverage            = mempty, --TODO: don't merge+      configLibCoverage         = mempty, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = mempty,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = mempty,+      configDebugInfo           = mempty,+      configAllowNewer          = mempty+    }++    haddockFlags = mempty {+      haddockKeepTempFiles = projectConfigKeepTempFiles+    }+++convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig+convertToLegacyPerPackageConfig PackageConfig {..} =+    LegacyPackageConfig {+      legacyConfigureFlags  = configFlags,+      legacyInstallPkgFlags = installFlags,+      legacyHaddockFlags    = haddockFlags+    }+  where+    configFlags = ConfigFlags {+      configPrograms_           = configPrograms_ mempty,+      configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),+      configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),+      configProgramPathExtra    = packageConfigProgramPathExtra,+      configHcFlavor            = mempty,+      configHcPath              = mempty,+      configHcPkg               = mempty,+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configDynExe              = packageConfigDynExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty,+      configPackageDBs          = mempty,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configIPID                = mempty,+      configConfigurationsFlags = packageConfigFlagAssignment,+      configTests               = packageConfigTests,+      configCoverage            = packageConfigCoverage, --TODO: don't merge+      configLibCoverage         = packageConfigCoverage, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = packageConfigBenchmarks,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = packageConfigRelocatable,+      configDebugInfo           = packageConfigDebugInfo,+      configAllowNewer          = mempty+    }++    installFlags = mempty {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    }++    haddockFlags = HaddockFlags {+      haddockProgramPaths  = mempty,+      haddockProgramArgs   = mempty,+      haddockHoogle        = packageConfigHaddockHoogle,+      haddockHtml          = packageConfigHaddockHtml,+      haddockHtmlLocation  = packageConfigHaddockHtmlLocation,+      haddockForHackage    = mempty, --TODO: added recently+      haddockExecutables   = packageConfigHaddockExecutables,+      haddockTestSuites    = packageConfigHaddockTestSuites,+      haddockBenchmarks    = packageConfigHaddockBenchmarks,+      haddockInternal      = packageConfigHaddockInternal,+      haddockCss           = packageConfigHaddockCss,+      haddockHscolour      = packageConfigHaddockHscolour,+      haddockHscolourCss   = packageConfigHaddockHscolourCss,+      haddockContents      = packageConfigHaddockContents,+      haddockDistPref      = mempty,+      haddockKeepTempFiles = mempty,+      haddockVerbosity     = mempty+    }+++------------------------------------------------+-- Parsing and showing the project config file+--++parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig+parseLegacyProjectConfig =+    parseConfig legacyProjectConfigFieldDescrs+                legacyPackageConfigSectionDescrs+                mempty++showLegacyProjectConfig :: LegacyProjectConfig -> String+showLegacyProjectConfig config =+    Disp.render $+    showConfig  legacyProjectConfigFieldDescrs+                legacyPackageConfigSectionDescrs+                config+  $+$+    Disp.text ""+++legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig]+legacyProjectConfigFieldDescrs =++    [ newLineListField "packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackages+        (\v flags -> flags { legacyPackages = v })+    , newLineListField "optional-packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackagesOptional+        (\v flags -> flags { legacyPackagesOptional = v })+    , commaNewLineListField "extra-packages"+        disp parse+        legacyPackagesNamed+        (\v flags -> flags { legacyPackagesNamed = v })+    ]++ ++ map (liftField+           legacySharedConfig+           (\flags conf -> conf { legacySharedConfig = flags }))+        legacySharedConfigFieldDescrs++ ++ map (liftField+           legacyLocalConfig+           (\flags conf -> conf { legacyLocalConfig = flags }))+        legacyPackageConfigFieldDescrs++-- | This is a bit tricky since it has to cover globs which have embedded @,@+-- chars. But we don't just want to parse strictly as a glob since we want to+-- allow http urls which don't parse as globs, and possibly some+-- system-dependent file paths. So we parse fairly liberally as a token, but+-- we allow @,@ inside matched @{}@ braces.+--+parsePackageLocationTokenQ :: ReadP r String+parsePackageLocationTokenQ = parseHaskellString+                   Parse.<++ parsePackageLocationToken+  where+    parsePackageLocationToken :: ReadP r String+    parsePackageLocationToken = fmap fst (Parse.gather outerTerm)+      where+        outerTerm   = alternateEither1 outerToken (braces innerTerm)+        innerTerm   = alternateEither  innerToken (braces innerTerm)+        outerToken  = Parse.munch1 outerChar >> return ()+        innerToken  = Parse.munch1 innerChar >> return ()+        outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')+        innerChar c = not (isSpace c || c == '{' || c == '}')+        braces      = Parse.between (Parse.char '{') (Parse.char '}')++    alternateEither, alternateEither1,+      alternatePQs, alternate1PQs, alternateQsP, alternate1QsP+      :: ReadP r () -> ReadP r () -> ReadP r ()++    alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p+    alternateEither  p q = alternateEither1 p q +++ return ()+    alternate1PQs    p q = p >> alternateQsP q p+    alternatePQs     p q = alternate1PQs p q +++ return ()+    alternate1QsP    q p = Parse.many1 q >> alternatePQs p q+    alternateQsP     q p = alternate1QsP q p +++ return ()++renderPackageLocationToken :: String -> String+renderPackageLocationToken s | needsQuoting = show s+                             | otherwise    = s+  where+    needsQuoting  = not (ok 0 s)+                 || s == "." -- . on its own on a line has special meaning+                 || take 2 s == "--" -- on its own line is comment syntax+                 --TODO: [code cleanup] these "." and "--" escaping issues+                 -- ought to be dealt with systematically in ParseUtils.+    ok :: Int -> String -> Bool+    ok n []       = n == 0+    ok _ ('"':_)  = False+    ok n ('{':cs) = ok (n+1) cs+    ok n ('}':cs) = ok (n-1) cs+    ok n (',':cs) = (n > 0) && ok n cs+    ok _ (c:_)+      | isSpace c = False+    ok n (_  :cs) = ok n cs+++legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig]+legacySharedConfigFieldDescrs =++  ( liftFields+      legacyGlobalFlags+      (\flags conf -> conf { legacyGlobalFlags = flags })+  . addFields+      [ newLineListField "local-repo"+          showTokenQ parseTokenQ+          (fromNubList . globalLocalRepos)+          (\v conf -> conf { globalLocalRepos = toNubList v })+      ]+  . filterFields+      [ "remote-repo-cache"+      , "logs-dir", "world-file", "ignore-expiry", "http-transport"+      ]+  . commandOptionsToFields+  ) (commandOptions (globalCommand []) ParseArgs)+ +++  ( liftFields+      legacyConfigureShFlags+      (\flags conf -> conf { legacyConfigureShFlags = flags })+  . addFields+      [ simpleField "allow-newer"+        (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer)+        configAllowNewer (\v conf -> conf { configAllowNewer = v })+      ]+  . filterFields ["verbose"]+  . commandOptionsToFields+  ) (configureOptions ParseArgs)+ +++  ( liftFields+      legacyConfigureExFlags+      (\flags conf -> conf { legacyConfigureExFlags = flags })+  . addFields+      [ commaNewLineListField "constraints"+        (disp . fst) (fmap (\constraint -> (constraint, constraintSrc)) parse)+        configExConstraints (\v conf -> conf { configExConstraints = v })++      , commaNewLineListField "preferences"+        disp parse+        configPreferences (\v conf -> conf { configPreferences = v })+      ]+  . filterFields+      [ "cabal-lib-version", "solver"+        -- not "constraint" or "preference", we use our own plural ones above+      ]+  . commandOptionsToFields+  ) (configureExOptions ParseArgs constraintSrc)+ +++  ( liftFields+      legacyInstallFlags+      (\flags conf -> conf { legacyInstallFlags = flags })+  . addFields+      [ newLineListField "build-summary"+          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+          (fromNubList . installSummaryFile)+          (\v conf -> conf { installSummaryFile = toNubList v })+      ]+  . filterFields+      [ "doc-index-file"+      , "root-cmd", "symlink-bindir"+      , "build-log"+      , "remote-build-reporting", "report-planning-failure"+      , "one-shot", "jobs", "offline"+        -- solver flags:+      , "max-backjumps", "reorder-goals", "strong-flags"+      ]+  . 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)++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"+++legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]+legacyPackageConfigFieldDescrs =+  ( liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+  . addFields+      [ newLineListField "extra-include-dirs"+          showTokenQ parseTokenQ+          configExtraIncludeDirs+          (\v conf -> conf { configExtraIncludeDirs = v })+      , newLineListField "extra-lib-dirs"+          showTokenQ parseTokenQ+          configExtraLibDirs+          (\v conf -> conf { configExtraLibDirs = v })+      , newLineListField "extra-framework-dirs"+          showTokenQ parseTokenQ+          configExtraFrameworkDirs+          (\v conf -> conf { configExtraFrameworkDirs = v })+      , newLineListField "extra-prog-path"+          showTokenQ parseTokenQ+          (fromNubList . configProgramPathExtra)+          (\v conf -> conf { configProgramPathExtra = toNubList v })+      , newLineListField "configure-options"+          showTokenQ parseTokenQ+          configConfigureArgs+          (\v conf -> conf { configConfigureArgs = v })+      , simpleField "flags"+          dispFlagAssignment parseFlagAssignment+          configConfigurationsFlags+          (\v conf -> conf { configConfigurationsFlags = v })+      ]+  . filterFields+      [ "compiler", "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"+      , "executable-stripping", "library-stripping"+      , "tests", "benchmarks"+      , "coverage", "library-coverage"+      , "relocatable"+        -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"+        -- or "extra-prog-path". We use corrected ones above that parse+        -- as list fields.+      ]+  . commandOptionsToFields+  ) (configureOptions ParseArgs)+ +++    liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+    [ overrideFieldCompiler+    , overrideFieldOptimization+    , overrideFieldDebugInfo+    ]+ +++  ( liftFields+      legacyInstallPkgFlags+      (\flags conf -> conf { legacyInstallPkgFlags = flags })+  . filterFields+      [ "documentation", "run-tests"+      ]+  . commandOptionsToFields+  ) (installOptions ParseArgs)+ +++  ( liftFields+      legacyHaddockFlags+      (\flags conf -> conf { legacyHaddockFlags = flags })+  . mapFieldNames+      ("haddock-"++)+  . filterFields+      [ "hoogle", "html", "html-location"+      , "executables", "tests", "benchmarks", "all", "internal", "css"+      , "hyperlink-source", "hscolour-css"+      , "contents-location", "keep-temp-files"+      ]+  . commandOptionsToFields+  ) (haddockOptions ParseArgs)++  where+    overrideFieldCompiler =+      simpleField "compiler"+        (fromFlagOrDefault Disp.empty . fmap disp)+        (Parse.option mempty (fmap toFlag parse))+        configHcFlavor (\v flags -> flags { configHcFlavor = v })+++    -- TODO: [code cleanup] The following is a hack. The "optimization" and+    -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.+    -- Instead of a hand-written parser and printer, we should handle this case+    -- properly in the library.++    overrideFieldOptimization =+      liftField configOptimization+                (\v flags -> flags { configOptimization = v }) $+      let name = "optimization" in+      FieldDescr name+        (\f -> case f of+                 Flag NoOptimisation      -> Disp.text "False"+                 Flag NormalOptimisation  -> Disp.text "True"+                 Flag MaximumOptimisation -> Disp.text "2"+                 _                        -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)+           |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)+           |  str == "0"     -> ParseOk [] (Flag NoOptimisation)+           |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)+           |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")++    overrideFieldDebugInfo =+      liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $+      let name = "debug-info" in+      FieldDescr name+        (\f -> case f of+                 Flag NoDebugInfo      -> Disp.text "False"+                 Flag MinimalDebugInfo -> Disp.text "1"+                 Flag NormalDebugInfo  -> Disp.text "True"+                 Flag MaximalDebugInfo -> Disp.text "3"+                 _                     -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)+           |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)+           |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)+           |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+++legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]+legacyPackageConfigSectionDescrs =+    [ packageRepoSectionDescr+    , packageSpecificOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programLocationsSectionDescr+    , liftSection+        legacySharedConfig+        (\flags conf -> conf { legacySharedConfig = flags }) $+      liftSection+        legacyGlobalFlags+        (\flags conf -> conf { legacyGlobalFlags = flags })+        remoteRepoSectionDescr+    ]++packageRepoSectionDescr :: SectionDescr LegacyProjectConfig+packageRepoSectionDescr =+    SectionDescr {+      sectionName        = "source-repository-package",+      sectionFields      = sourceRepoFieldDescrs,+      sectionSubsections = [],+      sectionGet         = map (\x->("", x))+                         . legacyPackagesRepo,+      sectionSet         =+        \lineno unused pkgrepo projconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'source-repository-package' takes no arguments"+          return projconf {+            legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]+          },+      sectionEmpty       = SourceRepo {+                             repoKind     = RepoThis, -- hopefully unused+                             repoType     = Nothing,+                             repoLocation = Nothing,+                             repoModule   = Nothing,+                             repoBranch   = Nothing,+                             repoTag      = Nothing,+                             repoSubdir   = Nothing+                           }+    }++packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig+packageSpecificOptionsSectionDescr =+    SectionDescr {+      sectionName        = "package",+      sectionFields      = legacyPackageConfigFieldDescrs+                        ++ programOptionsFieldDescrs+                             (configProgramArgs . legacyConfigureFlags)+                             (\args pkgconf -> pkgconf {+                                 legacyConfigureFlags = (legacyConfigureFlags pkgconf) {+                                   configProgramArgs  = args+                                 }+                               }+                             )+                        ++ liftFields+                             legacyConfigureFlags+                             (\flags pkgconf -> pkgconf {+                                 legacyConfigureFlags = flags+                               }+                             )+                             programLocationsFieldDescrs,+      sectionSubsections = [],+      sectionGet         = \projconf ->+                             [ (display pkgname, pkgconf)+                             | (pkgname, pkgconf) <-+                                 Map.toList . getMapMappend+                               . legacySpecificConfig $ projconf ],+      sectionSet         =+        \lineno pkgnamestr pkgconf projconf -> do+          pkgname <- case simpleParse pkgnamestr of+            Just pkgname -> return pkgname+            Nothing      -> syntaxError lineno $+                                "a 'package' section requires a package name "+                             ++ "as an argument"+          return projconf {+            legacySpecificConfig =+              MapMappend $+              Map.insertWith mappend pkgname pkgconf+                             (getMapMappend $ legacySpecificConfig projconf)+          },+      sectionEmpty       = mempty+    }++programOptionsFieldDescrs :: (a -> [(String, [String])])+                          -> ([(String, [String])] -> a -> a)+                          -> [FieldDescr a]+programOptionsFieldDescrs get set =+    commandOptionsToFields+  $ programConfigurationOptions+      defaultProgramDb+      ParseArgs get set++programOptionsSectionDescr :: SectionDescr LegacyPackageConfig+programOptionsSectionDescr =+    SectionDescr {+      sectionName        = "program-options",+      sectionFields      = programOptionsFieldDescrs+                             configProgramArgs+                             (\args conf -> conf { configProgramArgs = args }),+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-options' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }++programLocationsFieldDescrs :: [FieldDescr ConfigFlags]+programLocationsFieldDescrs =+     commandOptionsToFields+   $ programConfigurationPaths'+       (++ "-location")+       defaultProgramDb+       ParseArgs+       configProgramPaths+       (\paths conf -> conf { configProgramPaths = paths })++programLocationsSectionDescr :: SectionDescr LegacyPackageConfig+programLocationsSectionDescr =+    SectionDescr {+      sectionName        = "program-locations",+      sectionFields      = programLocationsFieldDescrs,+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-locations' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }+++-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- 'OptionField'.+programConfigurationOptions+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationOptions progConf 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)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])+           (\progArgs -> [ joinsArgs args+                         | (prog', args) <- progArgs, prog==prog' ]))+++    joinsArgs = unwords . map escape+    escape arg | any isSpace arg = "\"" ++ arg ++ "\""+               | otherwise       = arg+++remoteRepoSectionDescr :: SectionDescr GlobalFlags+remoteRepoSectionDescr =+    SectionDescr {+      sectionName        = "repository",+      sectionFields      = remoteRepoFields,+      sectionSubsections = [],+      sectionGet         = map (\x->(remoteRepoName x, x)) . fromNubList+                         . globalRemoteRepos,+      sectionSet         =+        \lineno reponame repo0 conf -> do+          when (null reponame) $+            syntaxError lineno $ "a 'repository' section requires the "+                              ++ "repository name as an argument"+          let repo = repo0 { remoteRepoName = reponame }+          when (remoteRepoKeyThreshold repo+                 > length (remoteRepoRootKeys repo)) $+            warning $ "'key-threshold' for repository "+                   ++ show (remoteRepoName repo)+                   ++ " higher than number of keys"+          when (not (null (remoteRepoRootKeys repo))+                && remoteRepoSecure repo /= Just True) $+            warning $ "'root-keys' for repository "+                   ++ show (remoteRepoName repo)+                   ++ " non-empty, but 'secure' not set to True."+          return conf {+            globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)+          },+      sectionEmpty       = emptyRemoteRepo ""+    }+++-------------------------------+-- Local field utils+--++--TODO: [code cleanup] all these utils should move to Distribution.ParseUtils+-- either augmenting or replacing the ones there++--TODO: [code cleanup] this is a different definition from listField, like+-- commaNewLineListField it pretty prints on multiple lines+newLineListField :: String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+newLineListField = listFieldWithSep Disp.sep++--TODO: [code cleanup] local copy purely so we can use the fixed version+-- 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' $+    ParseUtils.field name showF' (parseOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF++--TODO: [code cleanup] local redefinition that should replace the version in+-- D.ParseUtils. This version avoid parse ambiguity for list element parsers+-- that have multiple valid parses of prefixes.+parseOptCommaList :: ReadP r a -> ReadP r [a]+parseOptCommaList p = Parse.sepBy p sep+  where+    -- The separator must not be empty or it introduces ambiguity+    sep = (Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces)+      +++ (Parse.satisfy isSpace >> Parse.skipSpaces)++--TODO: [code cleanup] local redefinition that should replace the version in+-- D.ParseUtils called showFilePath. This version escapes "." and "--" which+-- otherwise are special syntax.+showTokenQ :: String -> Doc+showTokenQ ""            = Disp.empty+showTokenQ x@('-':'-':_) = Disp.text (show x)+showTokenQ x@('.':[])    = Disp.text (show x)+showTokenQ x             = showToken x++-- This is just a copy of parseTokenQ, using the fixed parseHaskellString+parseTokenQ :: ReadP r String+parseTokenQ = parseHaskellString+          <++ Parse.munch1 (\x -> not (isSpace x) && x /= ',')++--TODO: [code cleanup] use this to replace the parseHaskellString in+-- Distribution.ParseUtils. It turns out Read instance for String accepts+-- the ['a', 'b'] syntax, which we do not want. In particular it messes+-- up any token starting with [].+parseHaskellString :: ReadP r String+parseHaskellString =+  Parse.readS_to_P $+    Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0++-- Handy util+addFields :: [FieldDescr a]+          -> ([FieldDescr a] -> [FieldDescr a])+addFields = (++)
+ Distribution/Client/ProjectConfig/Types.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++-- | Handling project configuration, types.+--+module Distribution.Client.ProjectConfig.Types (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    PackageConfig(..),++    -- * Resolving configuration+    SolverSettings(..),+    BuildTimeSettings(..),++    -- * Extra useful Monoids+    MapLast(..),+    MapMappend(..),+  ) where++import Distribution.Client.Types+         ( RemoteRepo )+import Distribution.Client.Dependency.Types+         ( PreSolver, ConstraintSource )+import Distribution.Client.Targets+         ( UserConstraint )+import Distribution.Client.BuildReports.Types +         ( ReportLevel(..) )++import Distribution.Package+         ( PackageName, PackageId, UnitId, Dependency )+import Distribution.Version+         ( Version )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( FlagAssignment, SourceRepo(..) )+import Distribution.Simple.Compiler+         ( Compiler, CompilerFlavor+         , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )+import Distribution.Simple.Setup+         ( Flag, AllowNewer(..) )+import Distribution.Simple.InstallDirs+         ( PathTemplate )+import Distribution.Utils.NubList+         ( NubList )+import Distribution.Verbosity+         ( Verbosity )++import Data.Map (Map)+import qualified Data.Map as Map+import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Semigroup+import GHC.Generics (Generic)+++-------------------------------+-- Project config types+--++-- | This type corresponds directly to what can be written in the+-- @cabal.project@ file. Other sources of configuration can also be injected+-- into this type, such as the user-wide @~/.cabal/config@ file and the+-- command line of @cabal configure@ or @cabal build@.+--+-- Since it corresponds to the external project file it is an instance of+-- 'Monoid' and all the fields can be empty. This also means there has to+-- be a step where we resolve configuration. At a minimum resolving means+-- applying defaults but it can also mean merging information from multiple+-- sources. For example for package-specific configuration the project file+-- can specify configuration that applies to all local packages, and then+-- additional configuration for a specific package.+--+-- Future directions: multiple profiles, conditionals. If we add these+-- features then the gap between configuration as written in the config file+-- and resolved settings we actually use will become even bigger.+--+data ProjectConfig+   = ProjectConfig {++       -- | Packages in this project, including local dirs, local .cabal files+       -- local and remote tarballs. Where these are file globs, they must+       -- match something.+       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.+       projectPackagesOptional      :: [String],++       -- | Packages in this project from remote source repositories.+       projectPackagesRepo          :: [SourceRepo],++       -- | Packages in this project from hackage repositories.+       projectPackagesNamed         :: [Dependency],++       projectConfigBuildOnly       :: ProjectConfigBuildOnly,+       projectConfigShared          :: ProjectConfigShared,+       projectConfigLocalPackages   :: PackageConfig,+       projectConfigSpecificPackage :: MapMappend PackageName PackageConfig+     }+  deriving (Eq, Show, Generic)++-- | That part of the project configuration that only affects /how/ we build+-- and not the /value/ of the things we build. This means this information+-- does not need to be tracked for changes since it does not affect the+-- outcome.+--+data ProjectConfigBuildOnly+   = ProjectConfigBuildOnly {+       projectConfigVerbosity             :: Flag Verbosity,+       projectConfigDryRun                :: Flag Bool,+       projectConfigOnlyDeps              :: Flag Bool,+       projectConfigSummaryFile           :: NubList PathTemplate,+       projectConfigLogFile               :: Flag PathTemplate,+       projectConfigBuildReports          :: Flag ReportLevel,+       projectConfigReportPlanningFailure :: Flag Bool,+       projectConfigSymlinkBinDir         :: Flag FilePath,+       projectConfigOneShot               :: Flag Bool,+       projectConfigNumJobs               :: Flag (Maybe Int),+       projectConfigOfflineMode           :: Flag Bool,+       projectConfigKeepTempFiles         :: Flag Bool,+       projectConfigHttpTransport         :: Flag String,+       projectConfigIgnoreExpiry          :: Flag Bool,+       projectConfigCacheDir              :: Flag FilePath,+       projectConfigLogsDir               :: Flag FilePath,+       projectConfigWorldFile             :: Flag FilePath,+       projectConfigRootCmd               :: Flag String+     }+  deriving (Eq, Show, Generic)+++-- | Project configuration that is shared between all packages in the project.+-- In particular this includes configuration that affects the solver.+--+data ProjectConfigShared+   = ProjectConfigShared {+       projectConfigHcFlavor          :: Flag CompilerFlavor,+       projectConfigHcPath            :: Flag FilePath,+       projectConfigHcPkg             :: Flag FilePath,+       projectConfigHaddockIndex      :: Flag PathTemplate,++       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigUserInstall       :: Flag Bool,+     --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),+     --TODO: [required eventually] decide what to do with InstallDirs+     -- currently we don't allow it to be specified in the config file+     --projectConfigPackageDBs        :: [Maybe PackageDB],++       -- configuration used both by the solver and other phases+       projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.+       projectConfigLocalRepos        :: NubList FilePath,++       -- solver configuration+       projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],+       projectConfigPreferences       :: [Dependency],+       projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused+       projectConfigSolver            :: Flag PreSolver,+       projectConfigAllowNewer        :: Maybe AllowNewer,+       projectConfigMaxBackjumps      :: Flag Int,+       projectConfigReorderGoals      :: Flag Bool,+       projectConfigStrongFlags       :: Flag Bool++       -- More things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigIndependentGoals  :: Flag Bool,+     --projectConfigShadowPkgs        :: Flag Bool,+     --projectConfigReinstall         :: Flag Bool,+     --projectConfigAvoidReinstalls   :: Flag Bool,+     --projectConfigOverrideReinstall :: Flag Bool,+     --projectConfigUpgradeDeps       :: Flag Bool+     }+  deriving (Eq, Show, Generic)+++-- | Project configuration that is specific to each package, that is where we+-- can in principle have different values for different packages in the same+-- project.+--+data PackageConfig+   = PackageConfig {+       packageConfigProgramPaths        :: MapLast String FilePath,+       packageConfigProgramArgs         :: MapMappend String [String],+       packageConfigProgramPathExtra    :: NubList FilePath,+       packageConfigFlagAssignment      :: FlagAssignment,+       packageConfigVanillaLib          :: Flag Bool,+       packageConfigSharedLib           :: Flag Bool,+       packageConfigDynExe              :: Flag Bool,+       packageConfigProf                :: Flag Bool, --TODO: [code cleanup] sort out+       packageConfigProfLib             :: Flag Bool, --      this duplication+       packageConfigProfExe             :: Flag Bool, --      and consistency+       packageConfigProfDetail          :: Flag ProfDetailLevel,+       packageConfigProfLibDetail       :: Flag ProfDetailLevel,+       packageConfigConfigureArgs       :: [String],+       packageConfigOptimization        :: Flag OptimisationLevel,+       packageConfigProgPrefix          :: Flag PathTemplate,+       packageConfigProgSuffix          :: Flag PathTemplate,+       packageConfigExtraLibDirs        :: [FilePath],+       packageConfigExtraFrameworkDirs  :: [FilePath],+       packageConfigExtraIncludeDirs    :: [FilePath],+       packageConfigGHCiLib             :: Flag Bool,+       packageConfigSplitObjs           :: Flag Bool,+       packageConfigStripExes           :: Flag Bool,+       packageConfigStripLibs           :: Flag Bool,+       packageConfigTests               :: Flag Bool,+       packageConfigBenchmarks          :: Flag Bool,+       packageConfigCoverage            :: Flag Bool,+       packageConfigRelocatable         :: Flag Bool,+       packageConfigDebugInfo           :: Flag DebugInfoLevel,+       packageConfigRunTests            :: Flag Bool, --TODO: [required eventually] use this+       packageConfigDocumentation       :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHoogle       :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtml         :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this+       packageConfigHaddockExecutables  :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockTestSuites   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockInternal     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockCss          :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockHscolour     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHscolourCss  :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockContents     :: Flag PathTemplate --TODO: [required eventually] use this+     }+  deriving (Eq, Show, Generic)++instance Binary ProjectConfig+instance Binary ProjectConfigBuildOnly+instance Binary ProjectConfigShared+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)++instance Ord k => Monoid (MapLast k v) where+  mempty  = MapLast Map.empty+  mappend = (<>)++instance Ord k => Semigroup (MapLast k v) where+  MapLast a <> MapLast b = MapLast (flip Map.union a b)+  -- rather than Map.union which is the normal Map monoid instance+++-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that+-- 'mappend's values of overlapping keys rather than taking the first.+newtype MapMappend k v = MapMappend { getMapMappend :: Map k v }+  deriving (Eq, Show, Functor, Generic, Binary)++instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where+  mempty  = MapMappend Map.empty+  mappend = (<>)++instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where+  MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b)+  -- rather than Map.union which is the normal Map monoid instance+++instance Monoid ProjectConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfig where+  (<>) = gmappend+++instance Monoid ProjectConfigBuildOnly where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigBuildOnly where+  (<>) = gmappend+++instance Monoid ProjectConfigShared where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigShared where+  (<>) = gmappend+++instance Monoid PackageConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup PackageConfig where+  (<>) = gmappend++----------------------------------------+-- Resolving configuration to settings+--++-- | Resolved configuration for the solver. The idea is that this is easier to+-- use than the raw configuration because in the raw configuration everything+-- is optional (monoidial). In the 'BuildTimeSettings' every field is filled+-- in, if only with the defaults.+--+-- Use 'resolveSolverSettings' to make one from the project config (by+-- applying defaults etc).+--+data SolverSettings+   = SolverSettings {+       solverSettingRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+       solverSettingLocalRepos        :: [FilePath],+       solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],+       solverSettingPreferences       :: [Dependency],+       solverSettingFlagAssignment    :: FlagAssignment, -- ^ For all local packages+       solverSettingFlagAssignments   :: Map PackageName FlagAssignment,+       solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused+       solverSettingSolver            :: PreSolver,+       solverSettingAllowNewer        :: AllowNewer,+       solverSettingMaxBackjumps      :: Maybe Int,+       solverSettingReorderGoals      :: Bool,+       solverSettingStrongFlags       :: Bool+       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --solverSettingIndependentGoals  :: Bool,+     --solverSettingShadowPkgs        :: Bool,+     --solverSettingReinstall         :: Bool,+     --solverSettingAvoidReinstalls   :: Bool,+     --solverSettingOverrideReinstall :: Bool,+     --solverSettingUpgradeDeps       :: Bool+     }+  deriving (Eq, Show, Generic)++instance Binary SolverSettings+++-- | Resolved configuration for things that affect how we build and not the+-- value of the things we build. The idea is that this is easier to use than+-- the raw configuration because in the raw configuration everything is+-- optional (monoidial). In the 'BuildTimeSettings' every field is filled in,+-- if only with the defaults.+--+-- Use 'resolveBuildTimeSettings' to make one from the project config (by+-- applying defaults etc).+--+data BuildTimeSettings+   = BuildTimeSettings {+       buildSettingDryRun                :: Bool,+       buildSettingOnlyDeps              :: Bool,+       buildSettingSummaryFile           :: [PathTemplate],+       buildSettingLogFile               :: Maybe (Compiler  -> Platform+                                                -> PackageId -> UnitId+                                                             -> FilePath),+       buildSettingLogVerbosity          :: Verbosity,+       buildSettingBuildReports          :: ReportLevel,+       buildSettingReportPlanningFailure :: Bool,+       buildSettingSymlinkBinDir         :: [FilePath],+       buildSettingOneShot               :: Bool,+       buildSettingNumJobs               :: Int,+       buildSettingOfflineMode           :: Bool,+       buildSettingKeepTempFiles         :: Bool,+       buildSettingRemoteRepos           :: [RemoteRepo],+       buildSettingLocalRepos            :: [FilePath],+       buildSettingCacheDir              :: FilePath,+       buildSettingHttpTransport         :: Maybe String,+       buildSettingIgnoreExpiry          :: Bool,+       buildSettingRootCmd               :: Maybe String+     }+
+ Distribution/Client/ProjectOrchestration.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++-- | This module deals with building and incrementally rebuilding a collection+-- of packages. It is what backs the @cabal build@ and @configure@ commands,+-- as well as being a core part of @run@, @test@, @bench@ and others. +--+-- The primary thing is in fact rebuilding (and trying to make that quick by+-- not redoing unnecessary work), so building from scratch is just a special+-- case.+--+-- The build process and the code can be understood by breaking it down into+-- three major parts:+--+-- * The 'ElaboratedInstallPlan' type+--+-- * The \"what to do\" phase, where we look at the all input configuration+--   (project files, .cabal files, command line etc) and produce a detailed+--   plan of what to do -- the 'ElaboratedInstallPlan'.+--+-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we+-- re-execute it.+--+-- As far as possible, the \"what to do\" phase embodies all the policy, leaving+-- the \"do it\" phase policy free. The first phase contains more of the+-- complicated logic, but it is contained in code that is either pure or just+-- has read effects (except cache updates). Then the second phase does all the+-- actions to build packages, but as far as possible it just follows the+-- instructions and avoids any logic for deciding what to do (apart from+-- recompilation avoidance in executing the plan).+--+-- This division helps us keep the code under control, making it easier to+-- understand, test and debug. So when you are extending these modules, please+-- think about which parts of your change belong in which part. It is+-- perfectly ok to extend the description of what to do (i.e. the +-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the+-- first phase. Also, the second phase does not have direct access to any of+-- the input configuration anyway; all the information has to flow via the+-- 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectOrchestration (+    -- * Pre-build phase: decide what to do.+    runProjectPreBuildPhase,+    CliConfigFlags,+    PreBuildHooks(..),+    ProjectBuildContext(..),++    -- ** Adjusting the plan+    selectTargets,+    printPlan,++    -- * Build phase: now do it.+    runProjectBuildPhase,+  ) where++import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanning+import           Distribution.Client.ProjectBuilding++import           Distribution.Client.Types+                   hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)+                          , DocsResult(..), TestsResult(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.BuildTarget+                   ( UserBuildTarget, resolveUserBuildTargets+                   , BuildTarget(..), buildTargetPackage )+import           Distribution.Client.DistDirLayout+import           Distribution.Client.Config (defaultCabalDir)+import           Distribution.Client.Setup hiding (packageName)++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.Simple.Utils (die, notice)+import           Distribution.Verbosity+import           Distribution.Text++import qualified Data.Set as Set+import qualified Data.Map as Map+import           Data.Map (Map)+import           Data.List+import           Data.Either+++-- | Command line configuration flags. These are used to extend\/override the+-- project configuration.+--+type CliConfigFlags = ( GlobalFlags+                      , ConfigFlags, ConfigExFlags+                      , InstallFlags, HaddockFlags )++-- | 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+                            -> ProjectConfig+                            -> IO (),+       hookSelectPlanSubset :: ElaboratedInstallPlan+                            -> IO ElaboratedInstallPlan+     }++-- | This holds the context between the pre-build and build phases.+--+data ProjectBuildContext = ProjectBuildContext {+      distDirLayout    :: DistDirLayout,+      elaboratedPlan   :: ElaboratedInstallPlan,+      elaboratedShared :: ElaboratedSharedConfig,+      pkgsBuildStatus  :: BuildStatusMap,+      buildSettings    :: BuildTimeSettings+    }+++-- | Pre-build phase: decide what to do.+--+runProjectPreBuildPhase :: Verbosity+                        -> CliConfigFlags+                        -> PreBuildHooks+                        -> 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++    -- 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) <-+      rebuildInstallPlan verbosity+                         projectRootDir distDirLayout cabalDirLayout+                         cliConfig++    let buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          (projectConfigShared    projectConfig)+                          (projectConfigBuildOnly projectConfig)+                          (projectConfigBuildOnly cliConfig)++    -- 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++    -- Check if any packages don't need rebuilding, and improve the plan.+    -- This also gives us more accurate reasons for the --dry-run output.+    --+    (elaboratedPlan'', pkgsBuildStatus) <-+      rebuildTargetsDryRun distDirLayout+                           elaboratedPlan'++    return ProjectBuildContext {+      distDirLayout,+      elaboratedPlan = elaboratedPlan'',+      elaboratedShared,+      pkgsBuildStatus,+      buildSettings+    }+++-- | Build phase: now do it.+--+-- Execute all or parts of the description of what to do to build or+-- rebuild the various packages needed.+--+runProjectBuildPhase :: Verbosity+                     -> ProjectBuildContext+                     -> IO ()+runProjectBuildPhase verbosity ProjectBuildContext {..} = do+    _ <- rebuildTargets verbosity+                        distDirLayout+                        elaboratedPlan+                        elaboratedShared+                        pkgsBuildStatus+                        buildSettings+    --TODO return the result plan and use it for other status reporting+    return ()++    -- Note that it is a deliberate design choice that the 'buildTargets' is+    -- not passed to phase 1, and the various bits of input config is not+    -- passed to phase 2.+    --+    -- We make the install plan without looking at the particular targets the+    -- user asks us to build. The set of available things we can build is+    -- discovered from the env and config and is used to make the install plan.+    -- The targets just tell us which parts of the install plan to execute.+    --+    -- Conversely, executing the plan does not directly depend on any of the+    -- input config. The bits that are needed (or better, the decisions based+    -- on it) all go into the install plan.++    -- Notionally, the 'BuildFlags' should be things that do not affect what+    -- we build, just how we do it. These ones of course do +++------------------------------------------------------------------------------+-- Taking targets into account, selecting what to build+--++-- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it+-- required to build the given user targets.+--+-- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable.+--+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++    --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+    -- hackage packages so we can resolve names to those. Though we don't+    -- 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?++++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+  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.++    -- 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 t@(BuildTargetModule pn cn mn)+      | Just ipkgid <- Map.lookup pn projLocalPkgs+      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn)))++      | Map.member pn projAllPkgs+      = Left (BuildTargetComponentNotProjectLocal t)++    checkTarget t@(BuildTargetFile pn cn fn)+      | Just ipkgid <- Map.lookup pn projLocalPkgs+      = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn)))++      | Map.member pn projAllPkgs+      = Left (BuildTargetComponentNotProjectLocal t)++    checkTarget t+      = Left (BuildTargetNotInProject (buildTargetPackage t))+++    projAllPkgs, projLocalPkgs :: Map PackageName InstalledPackageId+    projAllPkgs =+      Map.fromList+        [ (packageName pkg, installedPackageId pkg)+        | pkg <- InstallPlan.toList installPlan ]++    projLocalPkgs =+      Map.fromList+        [ (packageName pkg, installedPackageId 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?+        ]++    --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++reportBuildTargetProblems :: [BuildTargetProblem] -> IO a+reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem++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."++reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) =+        "The package " ++ display (buildTargetPackage t) ++ " is in the "+     ++ "project but it is not a locally unpacked package, so  "++reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined+++------------------------------------------------------------------------------+-- Displaying what we plan to do+--++-- | Print a user-oriented presentation of the install plan, indicating what+-- will be built.+--+printPlan :: Verbosity -> ProjectBuildContext -> IO ()+printPlan verbosity+          ProjectBuildContext {+            elaboratedPlan,+            pkgsBuildStatus,+            buildSettings = BuildTimeSettings{buildSettingDryRun}+          }++  | null pkgs+  = notice verbosity "Up to date"++  | verbosity >= verbose+  = notice verbosity $ unlines $+      ("In order, the following " ++ wouldWill ++ " be built:")+    : 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++    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+      " (" ++ showBuildStatus buildStatus ++ ")"++    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment+    nonDefaultFlags pkg = pkgFlagAssignment pkg \\ pkgFlagDefaults pkg++    showStanzas pkg = concat+                    $ [ " *test"+                      | TestStanzas  `Set.member` pkgStanzasEnabled pkg ]+                   ++ [ " *bench"+                      | BenchStanzas `Set.member` pkgStanzasEnabled pkg ]++    showTargets pkg+      | null (pkgBuildTargets pkg) = ""+      | otherwise+      = " (" ++ unwords [ showComponentTarget pkg t | t <- pkgBuildTargets pkg ]+             ++ ")"++    -- 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++    showBuildStatus status = case status of+      BuildStatusPreExisting -> "already installed"+      BuildStatusDownload {} -> "requires download & build"+      BuildStatusUnpack   {} -> "requires build"+      BuildStatusRebuild _ rebuild -> case rebuild of+        BuildStatusConfigure+          (MonitoredValueChanged _)   -> "configuration changed"+        BuildStatusConfigure mreason  -> showMonitorChangedReason mreason+        BuildStatusBuild _ buildreason -> case buildreason of+          BuildReasonDepsRebuilt      -> "dependency rebuilt"+          BuildReasonFilesChanged+            (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 (MonitoredValueChanged _)   = "value changed"+    showMonitorChangedReason  MonitorFirstRun     = "first run"+    showMonitorChangedReason  MonitorCorruptCache = "cannot read state cache"++linearizeInstallPlan :: ElaboratedInstallPlan -> [ElaboratedReadyPackage]+linearizeInstallPlan =+    unfoldr next+  where+    next plan = case InstallPlan.ready plan of+      []      -> Nothing+      (pkg:_) -> Just (pkg, plan')+        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?+
+ Distribution/Client/ProjectPlanOutput.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,+             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,+             ScopedTypeVariables #-}++-- | An experimental new UI for cabal for working with multiple packages+-----------------------------------------------------------------------------+module Distribution.Client.ProjectPlanOutput (+    writePlanExternalRepresentation,+  ) where++import           Distribution.Client.ProjectPlanning.Types+                   ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..)+                   , ElaboratedSharedConfig(..) )+import           Distribution.Client.DistDirLayout++import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.Utils.Json as J+import qualified Distribution.Client.ComponentDeps as ComponentDeps++import           Distribution.Package+import qualified Distribution.PackageDescription as PD+import           Distribution.Text+import           Distribution.Simple.Utils+import qualified Paths_cabal_install as Our (version)++import           Data.Monoid+import qualified Data.ByteString.Builder as BB+++-- | Write out a representation of the elaborated install plan.+--+-- This is for the benefit of debugging and external tools like editors.+--+writePlanExternalRepresentation :: DistDirLayout+                                -> ElaboratedInstallPlan+                                -> ElaboratedSharedConfig+                                -> IO ()+writePlanExternalRepresentation distDirLayout elaboratedInstallPlan+                                elaboratedSharedConfig =+    writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $+        BB.toLazyByteString+      . J.encodeToBuilder+      $ encodePlanAsJson elaboratedInstallPlan elaboratedSharedConfig++-- | Renders a subset of the elaborated install plan in a semi-stable JSON+-- format.+--+encodePlanAsJson :: ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value+encodePlanAsJson 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+             ]+  where+    jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan)++    -- ipi :: InstalledPackageInfo+    toJ (InstallPlan.PreExisting ipi) =+      -- installed packages currently lack configuration information+      -- such as their flag settings or non-lib components.+      --+      -- 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) ] ]+        ]++    -- 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) ]++    toJ _ = error "encodePlanToJson: only expecting PreExisting and Configured"++    -- TODO: maybe move this helper to "ComponentDeps" module?+    --       Or maybe define a 'Text' instance?+    comp2str c = case c of+        ComponentDeps.ComponentLib     -> "lib"+        ComponentDeps.ComponentExe s   -> "exe:"   <> s+        ComponentDeps.ComponentTest s  -> "test:"  <> s+        ComponentDeps.ComponentBench s -> "bench:" <> s+        ComponentDeps.ComponentSetup   -> "setup"++    jdisplay :: Text a => a -> J.Value+    jdisplay = J.String . display+
+ Distribution/Client/ProjectPlanning.hs view
@@ -0,0 +1,2266 @@+{-# 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 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 :: Platform -> PD.PackageDescription -> Maybe [Dependency]+defaultSetupDeps 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 platform ] +++        -- The Cabal dep is slightly special:+        --  * we omit the dep for the Cabal lib itself (since it bootstraps),+        --  * we constrain it to be less than 1.23 since all packages+        --    relying on later Cabal spec versions are supposed to use+        --    explit setup deps. Having this constraint also allows later+        --    Cabal lib versions to make breaking API changes without breaking+        --    all old Setup.hs scripts.+        [ Dependency cabalPkgname cabalConstraint+        | packageName pkg /= cabalPkgname ]+        where+          cabalConstraint   = orLaterVersion (PD.specVersion pkg)+                                `intersectVersionRanges`+                              earlierVersion cabalCompatMaxVer+        -- TODO/FIXME: turns out that constraining to less than 1.23 causes+        --             problems with GHC8 as there's too many important packages+        --             with Custom build-type, for which there wouldn't be any+        --             install-plan (as GHC8 requires Cabal-1.24+). So let's+        --             set an implicit upper bound `Cabal < 2` instead.+          cabalCompatMaxVer = Version [2] []++      -- 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 :: Platform -> [PackageName]+legacyCustomSetupPkgs (Platform _ os) =+    map PackageName $+        [ "array", "base", "binary", "bytestring", "containers"+        , "deepseq", "directory", "filepath", "pretty"+        , "process", "time" ]+     ++ [ "Win32" | os == Windows ]+     ++ [ "unix"  | os /= Windows ]++-- 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)
+ Distribution/Client/ProjectPlanning/Types.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}++-- | Types used while planning how to build everything in a project.+--+-- Primarily this is the 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectPlanning.Types (+    SolverInstallPlan,++    -- * Elaborated install plan types+    ElaboratedInstallPlan,+    ElaboratedConfiguredPackage(..),+    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(..),+    SubComponentTarget(..),++    -- * Setup script+    SetupScriptStyle(..),+  ) where++import           Distribution.Client.PackageHash++import           Distribution.Client.Types+                   hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)+                          , DocsResult(..), TestsResult(..) )+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, InstallPlan, GenericPlanPackage )+import           Distribution.Client.ComponentDeps (ComponentDeps)++import           Distribution.Package+                   hiding (InstalledPackageId, installedPackageId)+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import           Distribution.Simple.Compiler+import           Distribution.Simple.Program.Db+import           Distribution.ModuleName (ModuleName)+import           Distribution.Simple.LocalBuildInfo (ComponentName(..))+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Simple.InstallDirs (PathTemplate)+import           Distribution.Version++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++++-- | 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.+--+-- It does not include dynamic elements such as resources (such as http+-- connections).+--+type ElaboratedInstallPlan+   = GenericInstallPlan InstalledPackageInfo+                        ElaboratedConfiguredPackage+                        BuildSuccess BuildFailure++type ElaboratedPlanPackage+   = GenericPlanPackage InstalledPackageInfo+                        ElaboratedConfiguredPackage+                        BuildSuccess BuildFailure++--TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle+--      even platform and compiler could be different if we're building things+--      like a server + client with ghc + ghcjs+data ElaboratedSharedConfig+   = ElaboratedSharedConfig {++       pkgConfigPlatform      :: Platform,+       pkgConfigCompiler      :: Compiler, --TODO: [code cleanup] replace with CompilerInfo+       -- | The programs that the compiler configured (e.g. for GHC, the progs+       -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are+       -- used.+       pkgConfigCompilerProgs :: ProgramDb+     }+  deriving (Show, Generic)+  --TODO: [code cleanup] no Eq instance++instance Binary ElaboratedSharedConfig++data ElaboratedConfiguredPackage+   = ElaboratedConfiguredPackage {++       pkgInstalledId :: InstalledPackageId,+       pkgSourceId    :: PackageId,++       -- | TODO: [code cleanup] we don't need this, just a few bits from it:+       --   build type, spec version+       pkgDescription :: Cabal.PackageDescription,++       -- | A total flag assignment for the package+       pkgFlagAssignment   :: Cabal.FlagAssignment,++       -- | The original default flag assignment, used only for reporting.+       pkgFlagDefaults     :: Cabal.FlagAssignment,++       -- | The exact dependencies (on other plan packages)+       --+       pkgDependencies     :: ComponentDeps [ConfiguredId],++       -- | 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,++       -- | 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,++       -- | Which optional stanzas (ie testsuites, benchmarks) will actually+       -- be enabled during the package configure step.+       pkgStanzasEnabled :: Set OptionalStanza,++       -- | 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),++       -- | The hash of the source, e.g. the tarball. We don't have this for+       -- local source dir packages.+       pkgSourceHash     :: 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++       pkgBuildStyle             :: BuildStyle,++       pkgSetupPackageDBStack    :: PackageDBStack,+       pkgBuildPackageDBStack    :: PackageDBStack,+       pkgRegisterPackageDBStack :: PackageDBStack,++       -- | The package contains a library and so must be registered+       pkgRequiresRegistration :: Bool,+       pkgDescriptionOverride  :: Maybe CabalFileText,++       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,++       pkgProgramPaths          :: Map String FilePath,+       pkgProgramArgs           :: Map String [String],+       pkgProgramPathExtra      :: [FilePath],+       pkgConfigureScriptArgs   :: [String],+       pkgExtraLibDirs          :: [FilePath],+       pkgExtraFrameworkDirs    :: [FilePath],+       pkgExtraIncludeDirs      :: [FilePath],+       pkgProgPrefix            :: Maybe PathTemplate,+       pkgProgSuffix            :: Maybe PathTemplate,++       pkgInstallDirs           :: InstallDirs.InstallDirs FilePath,++       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,++       -- 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,++       -- | 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,++       -- Build time related:+       pkgBuildTargets          :: [ComponentTarget],+       pkgReplTarget            :: Maybe ComponentTarget,+       pkgBuildHaddocks         :: Bool+     }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedConfiguredPackage++instance Package ElaboratedConfiguredPackage where+  packageId = pkgSourceId++instance HasUnitId ElaboratedConfiguredPackage where+  installedUnitId = pkgInstalledId++instance PackageFixedDeps ElaboratedConfiguredPackage where+  depends = fmap (map installedPackageId) . pkgDependencies++-- | This is used in the install plan to indicate how the package will be+-- built.+--+data BuildStyle =+    -- | The classic approach where the package is built, then the files+    -- installed into some location and the result registered in a package db.+    --+    -- If the package came from a tarball then it's built in a temp dir and+    -- the results discarded.+    BuildAndInstall++    -- | The package is built, but the files are not installed anywhere,+    -- rather the build dir is kept and the package is registered inplace.+    --+    -- Such packages can still subsequently be installed.+    --+    -- Typically 'BuildAndInstall' packages will only depend on other+    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.+    --+  | BuildInplaceOnly+  deriving (Eq, Show, Generic)++instance Binary BuildStyle++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.+--+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)++instance Binary PackageTarget+instance Binary ComponentTarget+instance Binary SubComponentTarget+++---------------------------+-- Setup.hs script policy+--++-- | There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API. In case 3 we also have+-- to build an external Setup.hs script because the package needs a later+-- Cabal lib version than we can support internally.+--+data SetupScriptStyle = SetupCustomExplicitDeps+                      | SetupCustomImplicitDeps+                      | SetupNonCustomExternalLib+                      | SetupNonCustomInternalLib+  deriving (Eq, Show, Generic)++instance Binary SetupScriptStyle+
+ Distribution/Client/RebuildMonad.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | An abstraction for re-running actions if values or files have changed.+--+-- This is not a full-blown make-style incremental build system, it's a bit+-- more ad-hoc than that, but it's easier to integrate with existing code.+--+-- It's a convenient interface to the "Distribution.Client.FileMonitor"+-- functions.+--+module Distribution.Client.RebuildMonad (+    -- * Rebuild monad+    Rebuild,+    runRebuild,+    askRoot,++    -- * Setting up file monitoring+    monitorFiles,+    MonitorFilePath,+    monitorFile,+    monitorFileHashed,+    monitorNonExistentFile,+    monitorDirectory,+    monitorNonExistentDirectory,+    monitorDirectoryExistence,+    monitorFileOrDirectory,+    monitorFileSearchPath,+    monitorFileHashedSearchPath,+    -- ** Monitoring file globs+    monitorFileGlob,+    monitorFileGlobExistence,+    FilePathGlob(..),+    FilePathRoot(..),+    FilePathGlobRel(..),+    GlobPiece(..),++    -- * Using a file monitor+    FileMonitor(..),+    newFileMonitor,+    rerunIfChanged,++    -- * Utils+    matchFileGlob,+  ) where++import Distribution.Client.FileMonitor+import Distribution.Client.Glob hiding (matchFileGlob)+import qualified Distribution.Client.Glob as Glob (matchFileGlob)++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)+++-- | A monad layered on top of 'IO' to help with re-running actions when the+-- input files and values they depend on change. The crucial operations are+-- 'rerunIfChanged' and 'monitorFiles'.+--+newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++-- | Use this wihin the body action of 'rerunIfChanged' to declare that the+-- action depends on the given files. This can be based on what the action+-- actually did. It is these files that will be checked for changes next+-- time 'rerunIfChanged' is called for that 'FileMonitor'.+--+-- Relative paths are interpreted as relative to an implicit root, ultimately+-- passed in to 'runRebuild'.+--+monitorFiles :: [MonitorFilePath] -> Rebuild ()+monitorFiles filespecs = Rebuild (State.modify (filespecs++))++-- | Run a 'Rebuild' IO action.+unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])+unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []++-- | Run a 'Rebuild' IO action.+runRebuild :: FilePath -> Rebuild a -> IO a+runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []++-- | The root that relative paths are interpreted as being relative to.+askRoot :: Rebuild FilePath+askRoot = Rebuild Reader.ask++-- | This captures the standard use pattern for a 'FileMonitor': given a+-- monitor, an action and the input value the action depends on, either+-- re-run the action to get its output, or if the value and files the action+-- depends on have not changed then return a previously cached action result.+--+-- The result is still in the 'Rebuild' monad, so these can be nested.+--+-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.+--+rerunIfChanged :: (Binary a, Binary b)+               => Verbosity+               -> FileMonitor a b+               -> a+               -> Rebuild b+               -> Rebuild b+rerunIfChanged verbosity monitor key action = do+    rootDir <- askRoot+    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key+    case changed of+      MonitorUnchanged result files -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                                    ++ "' unchanged."+        monitorFiles files+        return result++      MonitorChanged reason -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                ++ "' changed: " ++ showReason reason+        startTime <- liftIO $ beginUpdateFileMonitor+        (result, files) <- liftIO $ unRebuild rootDir action+        liftIO $ updateFileMonitor monitor rootDir+                                   (Just startTime) files key result+        monitorFiles files+        return result+  where+    monitorName = takeFileName (fileMonitorCacheFile monitor)++    showReason (MonitoredFileChanged file) = "file " ++ file+    showReason (MonitoredValueChanged _)   = "monitor value changed"+    showReason  MonitorFirstRun            = "first run"+    showReason  MonitorCorruptCache        = "invalid cache file"+++-- | Utility to match a file glob against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- Since this operates in the 'Rebuild' monad, it also monitors the given glob+-- for changes.+--+matchFileGlob :: FilePathGlob -> Rebuild [FilePath]+matchFileGlob glob = do+    root <- askRoot+    monitorFiles [monitorFileGlobExistence glob]+    liftIO $ Glob.matchFileGlob root glob+
Distribution/Client/Run.hs view
@@ -14,7 +14,10 @@ import Distribution.Client.Utils             (tryCanonicalizePath)  import Distribution.PackageDescription       (Executable (..),-                                              PackageDescription (..))+                                              TestSuite(..),+                                              Benchmark(..),+                                              PackageDescription (..),+                                              BuildInfo(buildable)) import Distribution.Simple.Compiler          (compilerFlavor, CompilerFlavor(..)) import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import Distribution.Simple.BuildPaths        (exeExtension)@@ -22,7 +25,8 @@                                               LocalBuildInfo (..),                                               getComponentLocalBuildInfo,                                               depLibraryPaths)-import Distribution.Simple.Utils             (die, notice, rawSystemExitWithEnv,+import Distribution.Simple.Utils             (die, notice, warn,+                                              rawSystemExitWithEnv,                                               addLibraryPath) import Distribution.System                   (Platform (..)) import Distribution.Verbosity                (Verbosity)@@ -33,32 +37,72 @@ import Data.Functor                          ((<$>)) #endif import Data.List                             (find)+import Data.Foldable                         (traverse_) import System.Directory                      (getCurrentDirectory) import Distribution.Compat.Environment       (getEnvironment) import System.FilePath                       ((<.>), (</>))   -- | Return the executable to run and any extra arguments that should be--- forwarded to it.-splitRunArgs :: LocalBuildInfo -> [String] -> IO (Executable, [String])-splitRunArgs lbi args =-  case exes of-    []    -> die "Couldn't find any executables."-    [exe] -> case args of-      []                        -> return (exe, [])-      (x:xs) | x == exeName exe -> return (exe, xs)-             | otherwise        -> return (exe, args)-    _     -> case args of-      []     -> die $ "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) exes of-        Nothing  -> die $ "No executable named '" ++ x ++ "'."-        Just exe -> return (exe, xs)+-- forwarded to it. Die in case of error.+splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]+             -> IO (Executable, [String])+splitRunArgs verbosity lbi args =+  case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)+    Left err               -> do+      warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.+      die err+    Right (True, exe, xs)  -> return (exe, xs)+    Right (False, exe, xs) -> do+      let addition = " Interpreting all parameters to `run` as a parameter to"+                     ++ " the default executable."+      -- If there is a warning, print it together with the addition.+      warn verbosity `traverse_` fmap (++addition) maybeWarning+      return (exe, xs)   where     pkg_descr = localPkgDescr lbi-    exes      = executables pkg_descr+    whichExecutable :: Either String       -- Error string.+                              ( Bool       -- If it was manually chosen.+                              , Executable -- The executable.+                              , [String]   -- The remaining parameters.+                              )+    whichExecutable = case (enabledExes, args) of+      ([]   , _)           -> Left "Couldn't find any enabled executables."+      ([exe], [])          -> return (False, exe, [])+      ([exe], (x:xs))+        | x == 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+          Nothing  -> Left $ "No executable named '" ++ x ++ "'."+          Just exe -> return (True, exe, xs)+      where+        enabledExes = filter (buildable . buildInfo) (executables pkg_descr) +    maybeWarning :: Maybe String+    maybeWarning = case args of+      []    -> Nothing+      (x:_) -> lookup x components+      where+        components :: [(String, String)] -- Component name, message.+        components =+          [ (name, "The executable '" ++ name ++ "' is disabled.")+          | e <- executables pkg_descr+          , not . buildable . buildInfo $ e, let name = exeName e]++          ++ [ (name, "There is a test-suite '" ++ name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | t <- testSuites pkg_descr+             , let name = testName t]++          ++ [ (name, "There is a benchmark '" ++ name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | b <- benchmarks pkg_descr+             , let name = benchmarkName b]  -- | Run a given executable. run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
Distribution/Client/Sandbox.hs view
@@ -21,6 +21,7 @@      getSandboxConfigFilePath,     loadConfigOrSandboxConfig,+    findSavedDistPref,     initPackageDBIfNeeded,     maybeWithSandboxDirOnSearchPath, @@ -35,20 +36,21 @@     sandboxBuildDir,     getInstalledPackagesInSandbox,     updateSandboxConfigFileFlag,+    updateInstallDirs, -    -- FIXME: move somewhere else-    configPackageDB', configCompilerAux'+    configPackageDB', configCompilerAux', getPersistOrConfigCompiler   ) where  import Distribution.Client.Setup   ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)   , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags-  , defaultSandboxLocation, globalRepos )+  , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps                                               , maybeAddCompilerTimestampRecord                                               , withAddTimestamps-                                              , withRemoveTimestamps )-import Distribution.Client.Config             ( SavedConfig(..), loadConfig )+                                              , removeTimestamps )+import Distribution.Client.Config+  ( SavedConfig(..), defaultUserInstall, loadConfig ) import Distribution.Client.Dependency         ( foldProgress ) import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) ) import Distribution.Client.Install            ( InstallArgs,@@ -58,17 +60,20 @@ import Distribution.Utils.NubList            ( fromNubList )  import Distribution.Client.Sandbox.PackageEnvironment-  ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)+  ( PackageEnvironment(..), PackageEnvironmentType(..)   , createPackageEnvironmentFile, classifyPackageEnvironment   , tryLoadSandboxPackageEnvironmentFile, loadUserConfig   , commentPackageEnvironment, showPackageEnvironmentWithComments-  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile )+  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile+  , sandboxPackageDBPath ) import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)                                               , UseSandbox(..) )+import Distribution.Client.SetupWrapper+  ( SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Types              ( PackageLocation(..)                                               , SourcePackage(..) ) import Distribution.Client.Utils              ( inDir, tryCanonicalizePath-                                              , tryFindAddSourcePackageDesc )+                                              , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription ) import Distribution.PackageDescription.Parse  ( readPackageDescription )@@ -76,11 +81,15 @@                                               , PackageDBStack ) import Distribution.Simple.Configure          ( configCompilerAuxEx                                               , interpretPackageDbFlags-                                              , getPackageDBContents )+                                              , getPackageDBContents+                                              , maybeGetPersistBuildConfig+                                              , findDistPrefOrDefault+                                              , findDistPref )+import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess         ( knownSuffixHandlers ) import Distribution.Simple.Program            ( ProgramConfiguration ) import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)-                                              , fromFlagOrDefault )+                                              , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist            ( prepareTree ) import Distribution.Simple.Utils              ( die, debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc@@ -90,7 +99,7 @@ import Distribution.System                    ( Platform ) import Distribution.Text                      ( display ) import Distribution.Verbosity                 ( Verbosity, lessVerbose )-import Distribution.Client.Compat.Environment ( lookupEnv, setEnv )+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 )@@ -98,30 +107,37 @@ import qualified Distribution.Simple.Register      as Register 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, liftM2, unless, when )+import Control.Monad                          ( forM, liftM, liftM2, unless, when ) import Data.Bits                              ( shiftL, shiftR, xor ) import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef )-import Data.List                              ( delete, foldl' )-import Data.Maybe                             ( fromJust, fromMaybe )+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                       ( createDirectory+import System.Directory                       ( canonicalizePath+                                              , createDirectory                                               , doesDirectoryExist                                               , doesFileExist                                               , getCurrentDirectory                                               , removeDirectoryRecursive                                               , removeFile                                               , renameDirectory )-import System.FilePath                        ( (</>), getSearchPath+import System.FilePath                        ( (</>), equalFilePath+                                              , getSearchPath                                               , searchPathSeparator+                                              , splitSearchPath                                               , takeDirectory ) - -- -- * Constants --@@ -169,8 +185,7 @@   case globalSandboxConfigFile globalFlags of     Flag _ -> return globalFlags     NoFlag -> do-      f' <- fmap (fromMaybe NoFlag . fmap Flag) . lookupEnv-            $ "CABAL_SANDBOX_CONFIG"+      f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG"       return globalFlags { globalSandboxConfigFile = f' }  -- | Return the path to the sandbox config file - either the default or the one@@ -302,13 +317,12 @@   setFileHidden sandboxDir    -- Determine which compiler to use (using the value from ~/.cabal/config).-  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag+  userConfig <- loadConfig verbosity (globalConfigFile globalFlags)   (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)    -- Create the package environment file.   pkgEnvFile <- getSandboxConfigFilePath globalFlags-  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile-    NoComments comp platform+  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform   (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   let config      = pkgEnvSavedConfig pkgEnv       configFlags = savedConfigureFlags config@@ -332,7 +346,6 @@   (useSandbox, _) <- loadConfigOrSandboxConfig                        verbosity                        globalFlags { globalRequireSandbox = Flag False }-                       mempty   case useSandbox of     NoSandbox -> warn verbosity "Not in a sandbox."     UseSandbox sandboxDir -> do@@ -341,8 +354,8 @@        -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard       -- location.-      let isNonDefaultConfigLocation =-            pkgEnvFile /= (curDir </> sandboxPackageEnvironmentFile)+      let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $+                                       curDir </> sandboxPackageEnvironmentFile        if isNonDefaultConfigLocation         then warn verbosity $ "Sandbox config file is in non-default location: '"@@ -350,17 +363,36 @@         else removeFile pkgEnvFile        -- Remove the sandbox directory, unless we're using a shared sandbox.-      let isNonDefaultSandboxLocation =-            sandboxDir /= (curDir </> defaultSandboxLocation)+      let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $+                                        curDir </> defaultSandboxLocation        when isNonDefaultSandboxLocation $         die $ "Non-default sandbox location used: '" ++ sandboxDir         ++ "'.\nAssuming a shared sandbox. Please delete '"         ++ sandboxDir ++ "' manually." -      notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir-      removeDirectoryRecursive sandboxDir+      absSandboxDir <- canonicalizePath sandboxDir+      notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir+      removeDirectoryRecursive absSandboxDir +      let+        pathInsideSandbox = isPrefixOf absSandboxDir++        -- Warn the user if deleting the sandbox deleted a package database+        -- referenced in the current environment.+        checkPackagePaths var = do+          let+            checkPath path = do+              absPath <- canonicalizePath path+              (when (pathInsideSandbox absPath) . warn verbosity)+                (var ++ " refers to package database " ++ path+                 ++ " inside the deleted sandbox.")+          liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath++      checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH"+      checkPackagePaths "GHC_PACKAGE_PATH"+      checkPackagePaths "GHCJS_PACKAGE_PATH"+ -- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'. doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment                -> BuildTreeRefType@@ -376,7 +408,7 @@     (compilerId comp) platform    withAddTimestamps sandboxDir $ do-    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it+    -- Path canonicalisation is done in addBuildTreeRefs, but we do it     -- twice because of the timestamps file.     buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs     Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType@@ -444,14 +476,54 @@   (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) -  withRemoveTimestamps sandboxDir $ do+  (results, convDict) <-     Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs +  let (failedPaths, removedPaths) = partitionEithers results+      removedRefs = fmap convDict removedPaths++  unless (null removedPaths) $ do+    removeTimestamps sandboxDir removedPaths++    notice verbosity $ "Success deleting sources: " +++      showL removedRefs ++ "\n\n"++  unless (null failedPaths) $ do+    let groupedFailures = groupBy errorType failedPaths+    mapM_ handleErrors groupedFailures+    die $ "The sources with the above errors were skipped. (" +++      showL (fmap getPath failedPaths) ++ ")"+   notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++     "source dependency, but does not remove the package " ++     "from the sandbox package DB.\n\n" ++     "Use 'sandbox hc-pkg -- unregister' to do that."+  where+    getPath (Index.ErrNonregisteredSource p) = p+    getPath (Index.ErrNonexistentSource p) = p +    showPaths f = concat . intersperse " " . fmap (show . f)++    showL = showPaths id++    showE [] = return ' '+    showE errs = showPaths getPath errs++    errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =+      True+    errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True+    errorType _ _ = False++    handleErrors [] = return ()+    handleErrors errs@(Index.ErrNonregisteredSource{}:_) =+      warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")+    handleErrors errs@(Index.ErrNonexistentSource{}:_)   =+      warn verbosity+      ("Source directory not found for paths: " ++ showE errs ++ "\n"+       ++ "If you are trying to delete a reference to a removed directory, "+       ++ "please provide the full absolute path "+       ++ "(as given by `sandbox list-sources`).\n\n")+ -- | Entry point for the 'cabal sandbox list-sources' command. sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags                       -> IO ()@@ -475,25 +547,47 @@ -- tool with provided arguments, restricted to the sandbox. sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do-  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv-      dbStack     = configPackageDB' configFlags-  (comp, _platform, conf) <- configCompilerAux' configFlags-+  -- 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+  let dir         = sandboxPackageDBPath sandboxDir comp platform+      dbStack     = [GlobalPackageDB, SpecificPackageDB dir]   Register.invokeHcPkg verbosity comp conf dbStack extraArgs +updateInstallDirs :: Flag Bool+                  -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)+updateInstallDirs userInstallFlag (useSandbox, savedConfig) =+  case useSandbox of+    NoSandbox ->+      let savedConfig' = savedConfig {+            savedConfigureFlags = configureFlags {+                configInstallDirs = installDirs+            }+          }+      in (useSandbox, savedConfig')+    _ -> (useSandbox, savedConfig)+  where+    configureFlags = savedConfigureFlags savedConfig+    userInstallDirs = savedUserInstallDirs savedConfig+    globalInstallDirs = savedGlobalInstallDirs savedConfig+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall+                  (configUserInstall configureFlags `mappend` userInstallFlag)+ -- | Check which type of package environment we're in and return a -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates -- whether we're working in a sandbox. loadConfigOrSandboxConfig :: Verbosity-                             -> GlobalFlags  -- ^ For @--config-file@ and-                                             -- @--sandbox-config-file@.-                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.-                             -> IO (UseSandbox, SavedConfig)-loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do+                          -> GlobalFlags  -- ^ For @--config-file@ and+                                          -- @--sandbox-config-file@.+                          -> IO (UseSandbox, SavedConfig)+loadConfigOrSandboxConfig verbosity globalFlags = do   let configFileFlag        = globalConfigFile        globalFlags       sandboxConfigFileFlag = globalSandboxConfigFile globalFlags-      ignoreSandboxFlag     = globalIgnoreSandbox globalFlags+      ignoreSandboxFlag     = globalIgnoreSandbox     globalFlags    pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag   pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag@@ -508,17 +602,22 @@      -- Only @cabal.config@ is present.     UserPackageEnvironment    -> do-      config <- loadConfig verbosity configFileFlag userInstallFlag-      userConfig <- loadUserConfig verbosity pkgEnvDir+      config <- loadConfig verbosity configFileFlag+      userConfig <- loadUserConfig verbosity pkgEnvDir Nothing       let config' = config `mappend` userConfig       dieIfSandboxRequired config'       return (NoSandbox, config')      -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.     AmbientPackageEnvironment -> do-      config <- loadConfig verbosity configFileFlag userInstallFlag+      config <- loadConfig verbosity configFileFlag+      let globalConstraintsOpt =+            flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config+      globalConstraintConfig <-+        loadUserConfig verbosity pkgEnvDir globalConstraintsOpt+      let config' = config `mappend` globalConstraintConfig       dieIfSandboxRequired config-      return (NoSandbox, config)+      return (NoSandbox, config')    where     -- Return the path to the package environment directory - either the@@ -542,6 +641,14 @@         checkFlag (Flag False) = return ()         checkFlag (NoFlag)     = return () +-- | Return the saved \"dist/\" prefix, or the default prefix.+findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath+findSavedDistPref config flagDistPref = do+    let defDistPref = useDistPref defaultSetupScriptOptions+        flagDistPref' = configDistPref (savedConfigureFlags config)+                        `mappend` flagDistPref+    findDistPref defDistPref flagDistPref'+ -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do -- nothing. maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a@@ -573,9 +680,10 @@                          comp platform conf sandboxDir $ \sandboxPkgInfo ->     unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do +     withRepoContext verbosity globalFlags $ \repoContext -> do       let args :: InstallArgs           args = ((configPackageDB' configFlags)-                 ,(globalRepos globalFlags)+                 ,repoContext                  ,comp, platform, conf                  ,UseSandbox sandboxDir, Just sandboxPkgInfo                  ,globalFlags, configFlags, configExFlags, installFlags@@ -599,9 +707,8 @@       -- TODO: use a better error message, remove duplication.       installFailedInSandbox =         "Note: when using a sandbox, all packages are required to have "-        ++ "consistent dependencies. "-        ++ "Try reinstalling/unregistering the offending packages or "-        ++ "recreating the sandbox."+        ++ "consistent dependencies. Try reinstalling/unregistering the "+        ++ "offending packages or recreating the sandbox."       logMsg message rest = debugNoWrap verbosity message >> rest        topHandler' = topHandlerWith $ \_ -> do@@ -665,8 +772,8 @@     toSourcePackage (path, pkgDesc) = SourcePackage       (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing --- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op--- otherwise.+-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the+-- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags                                -> Compiler -> Platform -> ProgramConfiguration                                -> UseSandbox@@ -688,13 +795,12 @@                                -> ConfigFlags      -- ^ Saved configure flags                                                    -- (from dist/setup-config)                                -> GlobalFlags-                               -> IO (UseSandbox, SavedConfig-                                     ,WereDepsReinstalled)-maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags'-                          (configUserInstall configFlags')+                               -> (UseSandbox, SavedConfig)+                               -> IO WereDepsReinstalled+maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags'+                            globalFlags' (useSandbox, config) = do   case useSandbox of-    NoSandbox             -> return (NoSandbox, config, NoDepsReinstalled)+    NoSandbox             -> return NoDepsReinstalled     UseSandbox sandboxDir -> do       -- Reinstall the modified add-source deps.       let configFlags    = savedConfigureFlags config@@ -713,10 +819,9 @@           -- from the command line. These options are hidden, and are only           -- useful for debugging, so this should be fine.                            `mappend` globalFlags'-      depsReinstalled <- reinstallAddSourceDeps verbosity-                         configFlags configExFlags installFlags globalFlags-                         sandboxDir-      return (UseSandbox sandboxDir, config, depsReinstalled)+      reinstallAddSourceDeps+        verbosity configFlags configExFlags+        installFlags globalFlags sandboxDir    where @@ -764,3 +869,18 @@   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)+getPersistOrConfigCompiler configFlags = do+  distPref <- findDistPrefOrDefault (configDistPref configFlags)+  mlbi <- maybeGetPersistBuildConfig distPref+  case mlbi of+    Nothing  -> do configCompilerAux' configFlags+    Just lbi -> return ( LocalBuildInfo.compiler lbi+                       , LocalBuildInfo.hostPlatform lbi+                       , LocalBuildInfo.withPrograms lbi+                       )
Distribution/Client/Sandbox/Index.hs view
@@ -12,42 +12,44 @@     addBuildTreeRefs,     removeBuildTreeRefs,     ListIgnoredBuildTreeRefs(..), RefTypesToList(..),+    DeleteSourceError(..),     listBuildTreeRefs,     validateIndexPath,      defaultIndexFileName   ) where +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 ( BuildTreeRefType(..)                                       , refTypeFromTypeCode                                       , typeCodeFromRefType                                       , updatePackageIndexCacheFile-                                      , getSourcePackagesStrict )-import Distribution.Client.PackageIndex ( allPackages )-import Distribution.Client.Types ( Repo(..), LocalRepo(..)-                                 , SourcePackageDb(..)-                                 , SourcePackage(..), PackageLocation(..) )+                                      , readCacheStrict+                                      , Index(..) )+import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString                                  , makeAbsoluteToCwd, tryCanonicalizePath-                                 , canonicalizePathNoThrow                                  , tryFindAddSourcePackageDesc  )  import Distribution.Simple.Utils ( die, debug )+import Distribution.Compat.Exception   ( tryIO ) import Distribution.Verbosity    ( Verbosity )  import qualified Data.ByteString.Lazy as BS-import Control.Exception         ( evaluate )+import Control.Exception         ( evaluate, throw, Exception ) import Control.Monad             ( liftM, unless )-import Data.List                 ( (\\), intersect, nub )-import Data.Maybe                ( catMaybes )+import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)+import Data.List                 ( (\\), intersect, nub, find )+import Data.Maybe                ( catMaybes, fromMaybe )+import Data.Either               (partitionEithers) import System.Directory          ( createDirectoryIfMissing,                                    doesDirectoryExist, doesFileExist,-                                   renameFile )-import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension-                                 , replaceExtension )-import System.IO                 ( IOMode(..), SeekMode(..)-                                 , hSeek, withBinaryFile )+                                   renameFile, canonicalizePath)+import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )+import System.IO                 ( IOMode(..), withBinaryFile )  -- | A reference to a local build tree. data BuildTreeRef = BuildTreeRef {@@ -80,16 +82,27 @@  -- | Given a sequence of tar archive entries, extract all references to local -- build trees.-readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef]+readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef] readBuildTreeRefs =   catMaybes-  . Tar.foldrEntries (\e r -> readBuildTreeRef e : r)-  [] error+  . Tar.foldEntries (\e r -> readBuildTreeRef e : r)+                    [] throw  -- | Given a path to a tar archive, extract all references to local build trees. readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef] readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile +-- | Read build tree references from an index cache+readBuildTreeRefsFromCache :: Verbosity -> FilePath -> IO [BuildTreeRef]+readBuildTreeRefsFromCache verbosity indexPath = do+    (mRefs, _prefs) <- readCacheStrict verbosity (SandboxIndex indexPath) buildTreeRef+    return (catMaybes mRefs)+  where+    buildTreeRef pkgEntry =+      case pkgEntry of+         IndexUtils.NormalPackage _ _ _ _ -> Nothing+         IndexUtils.BuildTreeRef typ _ _ path _ -> Just $ BuildTreeRef typ path+ -- | Given a local build tree ref, serialise it to a tar archive entry. writeBuildTreeRef :: BuildTreeRef -> Tar.Entry writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content@@ -143,45 +156,76 @@   treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)   let entries = map writeBuildTreeRef (catMaybes treesToAdd)   unless (null entries) $ do-    offset <--      fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error-            . Tar.read) $ BS.readFile path-    _ <- evaluate offset-    debug verbosity $ "Writing at offset: " ++ show offset     withBinaryFile path ReadWriteMode $ \h -> do-      hSeek h AbsoluteSeek (fromIntegral offset)+      block <- Tar.hSeekEndEntryOffset h Nothing+      debug verbosity $ "Writing at tar block: " ++ show block       BS.hPut h (Tar.write entries)       debug verbosity $ "Successfully appended to '" ++ path ++ "'"-    updatePackageIndexCacheFile verbosity path-      (path `replaceExtension` "cache")+    updatePackageIndexCacheFile verbosity $ SandboxIndex path +data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }+                       | ErrNonexistentSource   { nePath :: FilePath } deriving Show+ -- | Remove given local build tree references from the index.-removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]+--+-- Returns a tuple with either removed build tree refs or errors and a function+-- that converts from a provided build tree ref to corresponding full directory path.+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath]+                       -> IO ([Either DeleteSourceError FilePath],+                              (FilePath -> FilePath)) removeBuildTreeRefs _         _   [] =   error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"-removeBuildTreeRefs verbosity path l' = do-  checkIndexExists path-  l <- mapM canonicalizePathNoThrow l'-  let tmpFile = path <.> "tmp"+removeBuildTreeRefs verbosity indexPath l = do+  checkIndexExists indexPath+  let tmpFile = indexPath <.> "tmp"++  canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr+                               return $ case res of+                                 Right pth -> Right (btr, pth)+                                 Left _ -> Left $ ErrNonexistentSource btr) l+  let (failures, convDict) = partitionEithers canonRes+      allRefs = fmap snd convDict+   -- Performance note: on my system, it takes 'index --remove-source'   -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be   -- much smaller.-  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read-    =<< BS.readFile path-  renameFile tmpFile path+  removedRefs <- doRemove convDict tmpFile++  renameFile tmpFile indexPath   debug verbosity $ "Successfully renamed '" ++ tmpFile-    ++ "' to '" ++ path ++ "'"-  updatePackageIndexCacheFile verbosity path (path `replaceExtension` "cache")-  -- FIXME: return only the refs that vere actually removed.-  return l+    ++ "' to '" ++ indexPath ++ "'"++  unless (null removedRefs) $+    updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath++  let results = fmap Right removedRefs+                ++ fmap Left failures+                ++ fmap (Left . ErrNonregisteredSource)+                        (fmap (convertWith convDict) (allRefs \\ removedRefs))++  return (results, convertWith convDict)+     where-      p l entry = case readBuildTreeRef entry of-        Nothing                     -> True+      doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath]+      doRemove srcRefs tmpFile = do+        (newIdx, changedPaths) <-+          Tar.read `fmap` BS.readFile indexPath+          >>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs)+        BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx+        return changedPaths++      p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool+      p refs entry = case readBuildTreeRef entry of+        Nothing -> return True         -- FIXME: removing snapshot deps is done with `delete-source         -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to         -- support removing snapshots by providing the original path.-        (Just (BuildTreeRef _ pth)) -> pth `notElem` l+        (Just (BuildTreeRef _ pth)) -> if pth `elem` refs+                                       then tell [pth] >> return False+                                       else return True +      convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict+ -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user -- runs 'cabal sandbox list-sources', but do not look at their timestamps in@@ -222,16 +266,11 @@         LinksAndSnapshots -> const True        listWithIgnored :: IO [BuildTreeRef]-      listWithIgnored = readBuildTreeRefsFromFile $ path+      listWithIgnored = readBuildTreeRefsFromFile path        listWithoutIgnored :: IO [FilePath]-      listWithoutIgnored = do-        let repo = Repo { repoKind = Right LocalRepo-                        , repoLocalDir = takeDirectory path }-        pkgIndex <- fmap packageIndex-                    . getSourcePackagesStrict verbosity $ [repo]-        return [ pkgPath | (LocalUnpackedPackage pkgPath) <--                    map packageSource . allPackages $ pkgIndex ]+      listWithoutIgnored = fmap (map buildTreePath)+                         $ readBuildTreeRefsFromCache verbosity path   -- | Check that the package index file exists and exit with error if it does not.
Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.PackageEnvironment@@ -11,7 +12,6 @@  module Distribution.Client.Sandbox.PackageEnvironment (     PackageEnvironment(..)-  , IncludeComments(..)   , PackageEnvironmentType(..)   , classifyPackageEnvironment   , createPackageEnvironmentFile@@ -36,6 +36,7 @@                                        , installDirsFields, withProgramsFields                                        , withProgramOptionsFields                                        , defaultCompiler )+import Distribution.Client.Dependency.Types ( ConstraintSource (..) ) import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)                                        , InstallFlags(..)@@ -61,10 +62,8 @@ import Control.Monad                   ( foldM, liftM2, when, unless ) import Data.List                       ( partition ) import Data.Maybe                      ( isJust )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid                     ( Monoid(..) )-#endif import Distribution.Compat.Exception   ( catchIO )+import Distribution.Compat.Semigroup import System.Directory                ( doesDirectoryExist, doesFileExist                                        , renameFile ) import System.FilePath                 ( (<.>), (</>), takeDirectory )@@ -75,6 +74,7 @@ import qualified Distribution.Compat.ReadP as Parse import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) ) import qualified Distribution.Text         as Text+import GHC.Generics ( Generic )   --@@ -88,20 +88,14 @@   -- for constructing nested sandboxes (see discussion in #1196).   pkgEnvInherit       :: Flag FilePath,   pkgEnvSavedConfig   :: SavedConfig-}+} deriving Generic  instance Monoid PackageEnvironment where-  mempty = PackageEnvironment {-    pkgEnvInherit       = mempty,-    pkgEnvSavedConfig   = mempty-    }+  mempty = gmempty+  mappend = (<>) -  mappend a b = PackageEnvironment {-    pkgEnvInherit       = combine pkgEnvInherit,-    pkgEnvSavedConfig   = combine pkgEnvSavedConfig-    }-    where-      combine f = f a `mappend` f b+instance Semigroup PackageEnvironment where+  (<>) = gmappend  -- | The automatically-created package environment file that should not be -- touched by the user.@@ -276,31 +270,34 @@   case (pkgEnvInherit pkgEnv) of     NoFlag                -> return mempty     confPathFlag@(Flag _) -> do-      conf <- loadConfig verbosity confPathFlag NoFlag+      conf <- loadConfig verbosity confPathFlag       return $ mempty { pkgEnvSavedConfig = conf }  -- | Load the user package environment if it exists (the optional "cabal.config"--- file).-userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment-userPackageEnvironment verbosity pkgEnvDir = do-  let path = pkgEnvDir </> userPackageEnvironmentFile-  minp <- readPackageEnvironmentFile mempty path-  case minp of-    Nothing -> return mempty-    Just (ParseOk warns parseResult) -> do+-- file). If it does not exist locally, attempt to load an optional global one.+userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment+userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do+    let path = pkgEnvDir </> userPackageEnvironmentFile+    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) mempty path+    case (minp, globalConfigLocation) of+      (Just parseRes, _)  -> processConfigParse path parseRes+      (_, Just globalLoc) -> maybe (warn verbosity ("no constraints file found at " ++ globalLoc) >> return mempty) (processConfigParse globalLoc) =<< readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) mempty globalLoc+      _ -> return mempty+  where+    processConfigParse path (ParseOk warns parseResult) = do       when (not $ null warns) $ warn verbosity $         unlines (map (showPWarning path) warns)       return parseResult-    Just (ParseFailed err) -> do+    processConfigParse path (ParseFailed err) = do       let (line, msg) = locatedErrorMsg err-      warn verbosity $ "Error parsing user package environment file " ++ path+      warn verbosity $ "Error parsing package environment file " ++ path         ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg       return mempty  -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.-loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig-loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig-                                     $ userPackageEnvironment verbosity pkgEnvDir+loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig+loadUserConfig verbosity pkgEnvDir globalConfigLocation =+    fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation  -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'.@@ -327,7 +324,8 @@                                         -> IO (FilePath, PackageEnvironment) tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do   let pkgEnvDir = takeDirectory pkgEnvFile-  minp   <- readPackageEnvironmentFile mempty pkgEnvFile+  minp   <- readPackageEnvironmentFile+            (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile   pkgEnv <- handleParseResult verbosity pkgEnvFile minp    -- Get the saved sandbox directory.@@ -346,12 +344,11 @@    let base   = basePackageEnvironment   let common = commonPackageEnvironment sandboxDir-  user      <- userPackageEnvironment verbosity pkgEnvDir+  user      <- userPackageEnvironment verbosity pkgEnvDir Nothing --TODO   inherited <- inheritedPackageEnvironment verbosity user    -- Layer the package environment settings over settings from ~/.cabal/config.-  cabalConfig <- fmap unsetSymlinkBinDir $-                 loadConfig verbosity configFileFlag NoFlag+  cabalConfig <- fmap unsetSymlinkBinDir $ loadConfig verbosity configFileFlag   return (sandboxDir,           updateInstallDirs $           (base `mappend` (toPkgEnv cabalConfig) `mappend`@@ -382,35 +379,26 @@              }           } --- | Should the generated package environment file include comments?-data IncludeComments = IncludeComments | NoComments- -- | Create a new package environment file, replacing the existing one if it -- exists. Note that the path parameters should point to existing directories. createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath-                                -> IncludeComments                                 -> Compiler                                 -> Platform                                 -> IO ()-createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments-  compiler platform = do-  notice verbosity $ "Writing a default package environment file to "-    ++ pkgEnvFile--  commentPkgEnv <- commentPackageEnvironment sandboxDir+createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do+  notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile   initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform-  writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv+  writePackageEnvironmentFile pkgEnvFile initialPkgEnv  -- | Descriptions of all fields in the package environment file.-pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]-pkgEnvFieldDescrs = [+pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]+pkgEnvFieldDescrs src = [   simpleField "inherit"     (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)     pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v }) -    -- FIXME: Should we make these fields part of ~/.cabal/config ?   , commaNewLineListField "constraints"-    Text.disp Text.parse+    (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)     (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configExConstraints = v }))@@ -428,7 +416,7 @@     configFieldDescriptions' :: [FieldDescr SavedConfig]     configFieldDescriptions' = filter       (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")-      configFieldDescriptions+      (configFieldDescriptions src)      toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment     toPkgEnv fieldDescr =@@ -447,11 +435,11 @@       }  -- | Read the package environment file.-readPackageEnvironmentFile :: PackageEnvironment -> FilePath+readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath                               -> IO (Maybe (ParseResult PackageEnvironment))-readPackageEnvironmentFile initial file =+readPackageEnvironmentFile src initial file =   handleNotExists $-  fmap (Just . parsePackageEnvironment initial) (readFile file)+  fmap (Just . parsePackageEnvironment src initial) (readFile file)   where     handleNotExists action = catchIO action $ \ioe ->       if isDoesNotExistError ioe@@ -459,9 +447,9 @@         else ioError ioe  -- | Parse the package environment file.-parsePackageEnvironment :: PackageEnvironment -> String+parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String                            -> ParseResult PackageEnvironment-parsePackageEnvironment initial str = do+parsePackageEnvironment src initial str = do   fields <- readFields str   let (knownSections, others) = partition isKnownSection fields   pkgEnv <- parse others@@ -492,7 +480,7 @@     isKnownSection _                                                    = False      parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment-    parse = parseFields pkgEnvFieldDescrs initial+    parse = parseFields (pkgEnvFieldDescrs src) initial      parseSections :: SectionsAccum -> ParseUtils.Field                      -> ParseResult SectionsAccum@@ -535,18 +523,13 @@                      , [(String, FilePath)], [(String, [String])])  -- | Write out the package environment file.-writePackageEnvironmentFile :: FilePath -> IncludeComments-                               -> PackageEnvironment -> PackageEnvironment-                               -> IO ()-writePackageEnvironmentFile path incComments comments pkgEnv = do+writePackageEnvironmentFile :: FilePath -> PackageEnvironment -> IO ()+writePackageEnvironmentFile path pkgEnv = do   let tmpPath = (path <.> "tmp")   writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"   renameFile tmpPath path   where-    pkgEnvStr = case incComments of-      IncludeComments -> showPackageEnvironmentWithComments-                         (Just comments) pkgEnv-      NoComments      -> showPackageEnvironment pkgEnv+    pkgEnvStr = showPackageEnvironment pkgEnv     explanation = unlines       ["-- This is a Cabal package environment file."       ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."@@ -565,7 +548,8 @@                                       -> PackageEnvironment                                       -> String showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $-      ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv+      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)+               mdefPkgEnv pkgEnv   $+$ Disp.text ""   $+$ ppSection "install-dirs" "" installDirsFields                 (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)
Distribution/Client/Sandbox/Timestamp.hs view
@@ -10,13 +10,17 @@ module Distribution.Client.Sandbox.Timestamp (   AddSourceTimestamp,   withAddTimestamps,-  withRemoveTimestamps,   withUpdateTimestamps,   maybeAddCompilerTimestampRecord,   listModifiedDeps,+  removeTimestamps,++  -- * For testing+  TimestampFileRecord,+  readTimestampFile,+  writeTimestampFile   ) where -import Control.Exception                             (IOException) import Control.Monad                                 (filterM, forM, when) import Data.Char                                     (isSpace) import Data.List                                     (partition)@@ -25,37 +29,24 @@ import qualified Data.Map as M  import Distribution.Compiler                         (CompilerId)-import Distribution.Package                          (packageName)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Parse         (readPackageDescription)-import Distribution.Simple.Setup                     (Flag (..),-                                                      SDistFlags (..),-                                                      defaultSDistFlags,-                                                      sdistCommand) import Distribution.Simple.Utils                     (debug, die, warn) import Distribution.System                           (Platform) import Distribution.Text                             (display)-import Distribution.Verbosity                        (Verbosity, lessVerbose,-                                                      normal)-import Distribution.Version                          (Version (..),-                                                      orLaterVersion)+import Distribution.Verbosity                        (Verbosity) +import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Sandbox.Index   (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)   ,listBuildTreeRefs)-import Distribution.Client.SetupWrapper              (SetupScriptOptions (..),-                                                      defaultSetupScriptOptions,-                                                      setupWrapper)-import Distribution.Client.Utils-  (inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)  import Distribution.Compat.Exception                 (catchIO)-import Distribution.Client.Compat.Time               (EpochTime, getCurTime,-                                                      getModTime)+import Distribution.Client.Compat.Time               (ModTime, getCurTime,+                                                      getModTime,+                                                      posixSecondsToModTime)   -- | Timestamp of an add-source dependency.-type AddSourceTimestamp  = (FilePath, EpochTime)+type AddSourceTimestamp  = (FilePath, ModTime) -- | Timestamp file record - a string identifying the compiler & platform plus a -- list of add-source timestamps. type TimestampFileRecord = (String, [AddSourceTimestamp])@@ -79,15 +70,37 @@ readTimestampFile timestampFile = do   timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"   case reads timestampString of-    [(timestamps, s)] | all isSpace s -> return timestamps-    _                                 ->-      die $ "The timestamps file is corrupted. "-      ++ "Please delete & recreate the sandbox."+    [(version, s)]+      | version == (2::Int) ->+        case reads s of+          [(timestamps, s')] | all isSpace s' -> return timestamps+          _                                   -> dieCorrupted+      | otherwise   -> dieWrongFormat +    -- Old format (timestamps are POSIX seconds). Convert to new format.+    [] ->+      case reads timestampString of+        [(timestamps, s)] | all isSpace s -> do+          let timestamps' = map (\(i, ts) ->+                                  (i, map (\(p, t) ->+                                            (p, posixSecondsToModTime t)) ts))+                            timestamps+          writeTimestampFile timestampFile timestamps'+          return timestamps'+        _ -> dieCorrupted+    _ -> dieCorrupted+  where+    dieWrongFormat    = die $ wrongFormat ++ deleteAndRecreate+    dieCorrupted      = die $ corrupted ++ deleteAndRecreate+    wrongFormat       = "The timestamps file is in the wrong format."+    corrupted         = "The timestamps file is corrupted."+    deleteAndRecreate = " Please delete and recreate the sandbox."+ -- | Write the timestamp file, atomically. writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO () writeTimestampFile timestampFile timestamps = do-  writeFile  timestampTmpFile (show timestamps)+  writeFile  timestampTmpFile "2\n" -- version+  appendFile timestampTmpFile (show timestamps ++ "\n")   renameFile timestampTmpFile timestampFile   where     timestampTmpFile = timestampFile <.> "tmp"@@ -105,7 +118,7 @@ -- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list -- for each path. If a timestamp for a given path already exists in the list, -- update it.-addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]+addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]                  -> [AddSourceTimestamp] addTimestamps initial timestamps newPaths =   [ (p, initial) | p <- newPaths ] ++ oldTimestamps@@ -116,7 +129,7 @@ -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps -- we've reinstalled and a new timestamp value, update the timestamp value for -- the deps in the list. If there are new paths in the list, ignore them.-updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime+updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime                     -> [AddSourceTimestamp] updateTimestamps timestamps pathsToUpdate newTimestamp =   foldr updateTimestamp [] timestamps@@ -127,8 +140,8 @@  -- | Given a list of 'TimestampFileRecord's and a list of paths to add-source -- deps we've removed, remove those deps from the list.-removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]-removeTimestamps l pathsToRemove = foldr removeTimestamp [] l+removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]+removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l   where     removeTimestamp t@(path, _oldTimestamp) rest =       if path `elem` pathsToRemove@@ -156,13 +169,14 @@ -- build tree refs to the timestamps file (for all compilers). withAddTimestamps :: FilePath -> IO [FilePath] -> IO () withAddTimestamps sandboxDir act = do-  let initialTimestamp = 0+  let initialTimestamp = minBound   withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act --- | Given an IO action that returns a list of build tree refs, remove those+-- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers).-withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO ()-withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps+removeTimestamps :: FilePath -> [FilePath] -> IO ()+removeTimestamps idxFile =+  withActionOnAllTimestamps removeTimestamps' 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@@ -191,7 +205,7 @@ -- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result -- and then updates the timestamp file record. The IO action is run only once. withActionOnCompilerTimestamps :: ([AddSourceTimestamp]-                                   -> [FilePath] -> EpochTime+                                   -> [FilePath] -> ModTime                                    -> [AddSourceTimestamp])                                   -> FilePath                                   -> CompilerId@@ -209,47 +223,8 @@       else return r     return timestampRecords' --- | 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).--- FIXME: This function is not thread-safe because of 'inDir'.-allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]-allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do-  pkg <- do-    let err = "Error reading source files of add-source dependency."-    desc <- tryFindAddSourcePackageDesc packageDir err-    flattenPackageDescription `fmap` readPackageDescription verbosity desc-  let file      = "cabal-sdist-list-sources"-      flags     = defaultSDistFlags {-        sDistVerbosity   = Flag $ if verbosity == normal-                                  then lessVerbose verbosity else verbosity,-        sDistListSources = Flag file-        }-      setupOpts = defaultSetupScriptOptions {-        -- 'sdist --list-sources' was introduced in Cabal 1.18.-        useCabalVersion = orLaterVersion $ Version [1,18,0] []-        }--      doListSources :: IO [FilePath]-      doListSources = do-        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []-        srcs <- fmap lines . readFile $ file-        mapM tryCanonicalizePath srcs--      onFailedListSources :: IOException -> IO ()-      onFailedListSources e = do-        warn verbosity $-          "Could not list sources of the add-source dependency '"-          ++ display (packageName pkg) ++ "'. Skipping the timestamp check."-        debug verbosity $-          "Exception was: " ++ show e--  -- Run setup sdist --list-sources=TMPFILE-  ret <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])-  removeExistingFile file-  return ret- -- | Has this dependency been modified since we have last looked at it?-isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool+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@@ -257,9 +232,10 @@    where     go []         = return False-    go (dep:rest) = do+    go (dep0:rest) = do       -- FIXME: What if the clock jumps backwards at any point? For now we only       -- print a warning.+      let dep = packageDir </> dep0       modTime <- getModTime dep       when (modTime > now) $         warn verbosity $ "File '" ++ dep
Distribution/Client/Sandbox/Types.hs view
@@ -15,9 +15,10 @@  import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.Types (SourcePackage)+import Distribution.Compat.Semigroup (Semigroup((<>)))  #if !MIN_VERSION_base(4,8,0)-import Data.Monoid+import Data.Monoid (Monoid(..)) #endif import qualified Data.Set as S @@ -26,10 +27,12 @@  instance Monoid UseSandbox where   mempty = NoSandbox+  mappend = (<>) -  NoSandbox        `mappend` s                  = s-  u0@(UseSandbox _) `mappend` NoSandbox         = u0-  (UseSandbox   _)  `mappend` u1@(UseSandbox _) = u1+instance Semigroup UseSandbox where+  NoSandbox         <> s                 = s+  u0@(UseSandbox _) <> NoSandbox         = u0+  (UseSandbox _)    <> u1@(UseSandbox _) = u1  -- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with -- @when@.
+ Distribution/Client/Security/HTTP.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'+module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where++-- stdlibs+import Control.Exception+         ( Exception(..), IOException )+import Data.List+         ( intercalate )+import Data.Typeable+         ( Typeable )+import System.Directory+         ( getTemporaryDirectory )+import Network.URI+         ( URI )+import qualified Data.ByteString.Lazy as BS.L+import qualified Network.HTTP         as HTTP++-- Cabal/cabal-install+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Client.HttpUtils+         ( HttpTransport(..), HttpCode )+import Distribution.Client.Utils+         ( withTempFileName )++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Util.Lens as Lens++{-------------------------------------------------------------------------------+  'HttpLib' implementation+-------------------------------------------------------------------------------}++-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'+--+-- NOTE: The match between these two APIs is currently not perfect:+--+-- * We don't get any response headers back from the 'HttpTransport', so we+--   don't know if the server supports range requests. For now we optimistically+--   assume that it does.+-- * The 'HttpTransport' wants to know where to place the resulting file,+--   whereas the 'HttpLib' expects an 'IO' action which streams the download;+--   the security library then makes sure that the file gets written to a+--   location which is suitable (in particular, to a temporary file in the+--   directory where the file needs to end up, so that it can "finalize" the+--   file simply by doing 'renameFile'). Right now we write the file to a+--   temporary file in the system temp directory here and then read it again+--   to pass it to the security library; this is a problem for two reasons: it+--   is a source of inefficiency; and it means that the security library cannot+--   insist on a minimum download rate (potential security attack).+--   Fixing it however would require changing the 'HttpTransport'.+transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib+transportAdapter verbosity getTransport = HttpLib{+      httpGet      = \headers uri callback -> do+                        transport <- getTransport+                        get verbosity transport headers uri callback+    , httpGetRange = \headers uri range callback -> do+                        transport <- getTransport+                        getRange verbosity transport headers uri range callback+    }++get :: Throws SomeRemoteError+    => Verbosity+    -> HttpTransport+    -> [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get verbosity transport reqHeaders uri callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->+    case code of+      200 -> callback respHeaders br+      _   -> throwChecked $ UnexpectedResponse uri code++getRange :: Throws SomeRemoteError+         => Verbosity+         -> HttpTransport+         -> [HttpRequestHeader] -> URI -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->+    case code of+       200 -> callback HttpStatus200OK             respHeaders br+       206 -> callback HttpStatus206PartialContent respHeaders br+       _   -> throwChecked $ UnexpectedResponse uri code++-- | Internal generalization of 'get' and 'getRange'+get' :: Verbosity+     -> HttpTransport+     -> [HttpRequestHeader] -> URI -> Maybe (Int, Int)+     -> (HttpCode -> [HttpResponseHeader] -> BodyReader -> IO a)+     -> IO a+get' verbosity transport reqHeaders uri mRange callback = do+    tempDir <- getTemporaryDirectory+    withTempFileName tempDir "transportAdapterGet" $ \temp -> do+      (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'+      br <- bodyReaderFromBS =<< BS.L.readFile temp+      callback code [HttpResponseAcceptRangesBytes] br+  where+    reqHeaders' = mkReqHeaders reqHeaders mRange++{-------------------------------------------------------------------------------+  Request headers+-------------------------------------------------------------------------------}++mkRangeHeader :: Int -> Int -> HTTP.Header+mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)++mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]+mkReqHeaders reqHeaders mRange = concat [+      tr [] reqHeaders+    , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]+    ]+  where+    tr :: [(HTTP.HeaderName, [String])] -> [HttpRequestHeader] -> [HTTP.Header]+    tr acc [] =+      concatMap finalize acc+    tr acc (HttpRequestMaxAge0:os) =+      tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os+    tr acc (HttpRequestNoTransform:os) =+      tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we we just comma-separate all of them.+    finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]+    finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = Lens.modify (Lens.lookupM x) (++ y)++{-------------------------------------------------------------------------------+  Custom exceptions+-------------------------------------------------------------------------------}++data UnexpectedResponse = UnexpectedResponse URI Int+  deriving (Typeable)++instance Pretty UnexpectedResponse where+  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code+                                      ++ "for " ++ show uri++#if MIN_VERSION_base(4,8,0)+deriving instance Show UnexpectedResponse+instance Exception UnexpectedResponse where displayException = pretty+#else+instance Show UnexpectedResponse where show = pretty+instance Exception UnexpectedResponse+#endif++wrapCustomEx :: ( ( Throws UnexpectedResponse+                  , Throws IOException+                  ) => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ handleChecked (\(ex :: IOException)        -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)
Distribution/Client/Setup.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Setup@@ -12,19 +15,23 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos+    ( globalCommand, GlobalFlags(..), defaultGlobalFlags+    , RepoContext(..), withRepoContext     , configureCommand, ConfigFlags(..), filterConfigureFlags     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)     , replCommand, testCommand, benchmarkCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , defaultSolver, defaultMaxBackjumps     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand+    , uninstallCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)+    , genBoundsCommand     , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , formatCommand@@ -34,22 +41,25 @@     , initCommand, IT.InitFlags(..)     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)+    , actAsSetupCommand, ActAsSetupFlags(..)     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)     , execCommand, ExecFlags(..)     , userConfigCommand, UserConfigFlags(..)+    , manpageCommand      , parsePackageArgs     --TODO: stop exporting these:     , showRepo     , parseRepo+    , readRepo     ) where  import Distribution.Client.Types-         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )+         ( Username(..), Password(..), RemoteRepo(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( AllowNewer(..), PreSolver(..) )+         ( PreSolver(..), ConstraintSource(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets@@ -57,6 +67,7 @@ import Distribution.Utils.NubList          ( NubList, toNubList, fromNubList) + import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program          ( defaultProgramConfiguration )@@ -68,8 +79,9 @@          , TestFlags(..), BenchmarkFlags(..)          , SDistFlags(..), HaddockFlags(..)          , readPackageDbList, showPackageDbList-         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )+         , Flag(..), toFlag, flagToMaybe, flagToList+         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg+         , readPToMaybe, optionNumJobs ) import Distribution.Simple.InstallDirs          ( PathTemplate, InstallDirs(sysconfdir)          , toPathTemplate, fromPathTemplate )@@ -78,28 +90,31 @@ import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.PackageDescription-         ( RepoKind(..) )+         ( BuildType(..), RepoKind(..) ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )+         ( ReadP, char, munch1, pfail,  (+++) )+import Distribution.Compat.Semigroup import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils          ( wrapText, wrapLine )+import Distribution.Client.GlobalFlags+         ( GlobalFlags(..), defaultGlobalFlags+         , RepoContext(..), withRepoContext+         )  import Data.Char-         ( isSpace, isAlphaNum )+         ( isAlphaNum ) import Data.List-         ( intercalate, delete, deleteFirstsBy )+         ( intercalate, deleteFirstsBy ) import Data.Maybe-         ( listToMaybe, maybeToList, fromMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif+         ( maybeToList, fromMaybe )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary) import Control.Monad          ( liftM ) import System.FilePath@@ -107,40 +122,6 @@ import Network.URI          ( parseAbsoluteURI, uriToString ) --- --------------------------------------------------------------- * Global flags--- ---------------------------------------------------------------- | Flags that apply at the top level, not to any sub-command.-data GlobalFlags = GlobalFlags {-    globalVersion           :: Flag Bool,-    globalNumericVersion    :: Flag Bool,-    globalConfigFile        :: Flag FilePath,-    globalSandboxConfigFile :: Flag FilePath,-    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.-    globalCacheDir          :: Flag FilePath,-    globalLocalRepos        :: NubList FilePath,-    globalLogsDir           :: Flag FilePath,-    globalWorldFile         :: Flag FilePath,-    globalRequireSandbox    :: Flag Bool,-    globalIgnoreSandbox     :: Flag Bool-  }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion           = Flag False,-    globalNumericVersion    = Flag False,-    globalConfigFile        = mempty,-    globalSandboxConfigFile = mempty,-    globalRemoteRepos       = mempty,-    globalCacheDir          = mempty,-    globalLocalRepos        = mempty,-    globalLogsDir           = mempty,-    globalWorldFile         = mempty,-    globalRequireSandbox    = Flag False,-    globalIgnoreSandbox     = Flag False-  }- globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI {     commandName         = "",@@ -182,6 +163,7 @@           , "upload"           , "report"           , "freeze"+          , "gen-bounds"           , "haddock"           , "hscolour"           , "copy"@@ -232,6 +214,7 @@         , addCmd "report"         , par         , addCmd "freeze"+        , addCmd "gen-bounds"         , addCmd "haddock"         , addCmd "hscolour"         , addCmd "copy"@@ -256,9 +239,17 @@       ++ "  " ++ pname ++ " update\n",     commandNotes = Nothing,     commandDefaultFlags = mempty,-    commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)-      [option ['V'] ["version"]+    commandOptions = args+  }+  where+    args :: ShowOrParseArgs -> [OptionField GlobalFlags]+    args ShowArgs  = argsShown+    args ParseArgs = argsShown ++ argsNotShown++    -- arguments we want to show in the help+    argsShown :: [OptionField GlobalFlags]+    argsShown = [+       option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })          trueArg@@ -275,9 +266,14 @@        ,option [] ["sandbox-config-file"]          "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"-         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })+         globalSandboxConfigFile (\v flags -> flags { globalSandboxConfigFile = v })          (reqArgFlag "FILE") +      ,option [] ["default-user-config"]+         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."+         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})+         (reqArgFlag "FILE")+       ,option [] ["require-sandbox"]          "requiring the presence of a sandbox for sandbox-aware commands"          globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })@@ -288,7 +284,21 @@          globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })          trueArg -      ,option [] ["remote-repo"]+      ,option [] ["ignore-expiry"]+         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"+         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })+         trueArg++      ,option [] ["http-transport"]+         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"+         globalHttpTransport (\v flags -> flags { globalHttpTransport = v })+         (reqArgFlag "HttpTransport")+      ]++    -- arguments we don't want shown in the help+    argsNotShown :: [OptionField GlobalFlags]+    argsNotShown = [+       option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })          (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))@@ -313,92 +323,72 @@          globalWorldFile (\v flags -> flags { globalWorldFile = v })          (reqArgFlag "FILE")       ]-  } -instance Monoid GlobalFlags where-  mempty = GlobalFlags {-    globalVersion           = mempty,-    globalNumericVersion    = mempty,-    globalConfigFile        = mempty,-    globalSandboxConfigFile = mempty,-    globalRemoteRepos       = mempty,-    globalCacheDir          = mempty,-    globalLocalRepos        = mempty,-    globalLogsDir           = mempty,-    globalWorldFile         = mempty,-    globalRequireSandbox    = mempty,-    globalIgnoreSandbox     = mempty-  }-  mappend a b = GlobalFlags {-    globalVersion           = combine globalVersion,-    globalNumericVersion    = combine globalNumericVersion,-    globalConfigFile        = combine globalConfigFile,-    globalSandboxConfigFile = combine globalConfigFile,-    globalRemoteRepos       = combine globalRemoteRepos,-    globalCacheDir          = combine globalCacheDir,-    globalLocalRepos        = combine globalLocalRepos,-    globalLogsDir           = combine globalLogsDir,-    globalWorldFile         = combine globalWorldFile,-    globalRequireSandbox    = combine globalRequireSandbox,-    globalIgnoreSandbox     = combine globalIgnoreSandbox-  }-    where combine field = field a `mappend` field b--globalRepos :: GlobalFlags -> [Repo]-globalRepos globalFlags = remoteRepos ++ localRepos-  where-    remoteRepos =-      [ Repo (Left remote) cacheDir-      | remote <- fromNubList $ globalRemoteRepos globalFlags-      , let cacheDir = fromFlag (globalCacheDir globalFlags)-                   </> remoteRepoName remote ]-    localRepos =-      [ Repo (Right LocalRepo) local-      | local <- fromNubList $ globalLocalRepos globalFlags ]- -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------  configureCommand :: CommandUI ConfigFlags-configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {-    commandDefaultFlags = mempty+configureCommand = c+  { commandDefaultFlags = mempty+  , commandNotes = Just $ \pname -> (case commandNotes c of+         Nothing -> ""+         Just n  -> n pname ++ "\n")+       ++ "Examples:\n"+       ++ "  " ++ pname ++ " configure\n"+       ++ "    Configure with defaults;\n"+       ++ "  " ++ pname ++ " configure --enable-tests -fcustomflag\n"+       ++ "    Configure building package including tests,\n"+       ++ "    with some package-specific flag.\n"   }+ where+  c = Cabal.configureCommand defaultProgramConfiguration  configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand  filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,22,0] [] = flags_latest+  | cabalLibVersion >= Version [1,23,0] [] = 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   | otherwise = flags_latest   where-    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.-    flags_latest = flags        { configConstraints = [] }+    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+      -- '--exact-configuration' instead.+      configAllowNewer  = Just Cabal.AllowNewerNone+      } +    -- Cabal < 1.23 doesn't know about '--profiling-detail'.+    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag+                                , configProfLibDetail = NoFlag+                                , configIPID          = NoFlag }+     -- Cabal < 1.22 doesn't know about '--disable-debug-info'.-    flags_1_21_0 = flags_latest { configDebugInfo = NoFlag }+    flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }      -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'     -- Cabal < 1.21.1 doesn't know about 'enable-profiling'     flags_1_20_0 =       flags_1_21_0 { configRelocatable = NoFlag-                   , configProfExe = configProfExe flags-                   , configProfLib = configProfLib flags+                   , configProf = NoFlag+                   , configProfExe = configProf flags+                   , configProfLib =+                     mappend (configProf flags) (configProfLib flags)                    , configCoverage = NoFlag                    , configLibCoverage = configCoverage flags-                   -- HACK: See #2409.-                   , configProgramPaths =-                     ("cabalConfProf", "/TRUE") `delete` configProgramPaths flags                    }     -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and     -- '--enable-library-stripping'.@@ -413,8 +403,12 @@     configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }     -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.     flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }+    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'+    -- and '--enable/disable-library-coverage'.+    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag+                                , configDynExe      = NoFlag }     -- Cabal < 1.10.0 doesn't know about '--disable-tests'.-    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }+    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }     -- Cabal < 1.3.10 does not grok the '--constraints' flag.     flags_1_3_10 = flags_1_10_0 { configConstraints = [] } @@ -426,15 +420,14 @@ -- data ConfigExFlags = ConfigExFlags {     configCabalVersion :: Flag Version,-    configExConstraints:: [UserConstraint],+    configExConstraints:: [(UserConstraint, ConstraintSource)],     configPreferences  :: [Dependency],-    configSolver       :: Flag PreSolver,-    configAllowNewer   :: Flag AllowNewer+    configSolver       :: Flag PreSolver   }+  deriving (Eq, Generic)  defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver-                              , configAllowNewer = Flag AllowNewerNone }+defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }  configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand {@@ -443,14 +436,17 @@          liftOptions fst setFst          (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])                   . optionName) $ configureOptions  showOrParseArgs)-      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)+      ++ liftOptions snd setSnd+         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)   }   where     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]-configureExOptions _showOrParseArgs =+configureExOptions :: ShowOrParseArgs+                   -> ConstraintSource+                   -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs src =   [ option [] ["cabal-lib-version"]       ("Select which version of the Cabal lib to use to build packages "       ++ "(useful for testing).")@@ -462,8 +458,8 @@       "Specify constraints on a package (version, installed/source, flags)"       configExConstraints (\v flags -> flags { configExConstraints = v })       (reqArg "CONSTRAINT"-              (fmap (\x -> [x]) (ReadE readUserConstraint))-              (map display))+              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)+              (map $ display . fst))    , option [] ["preference"]       "Specify preferences (soft constraints) on the version of a package"@@ -475,33 +471,15 @@    , optionSolver configSolver (\v flags -> flags { configSolver = v }) -  , option [] ["allow-newer"]-    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)-    configAllowNewer (\v flags -> flags { configAllowNewer = v})-    (optArg allowNewerArgument-     (fmap Flag allowNewerParser) (Flag AllowNewerAll)-     allowNewerPrinter)-   ]-  where allowNewerArgument = "DEPS"  instance Monoid ConfigExFlags where-  mempty = ConfigExFlags {-    configCabalVersion = mempty,-    configExConstraints= mempty,-    configPreferences  = mempty,-    configSolver       = mempty,-    configAllowNewer   = mempty-  }-  mappend a b = ConfigExFlags {-    configCabalVersion = combine configCabalVersion,-    configExConstraints= combine configExConstraints,-    configPreferences  = combine configPreferences,-    configSolver       = combine configSolver,-    configAllowNewer   = combine configAllowNewer-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ConfigExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------@@ -512,7 +490,7 @@  data BuildExFlags = BuildExFlags {   buildOnly     :: Flag SkipAddSourceDepsCheck-}+} deriving Generic  buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags] buildExOptions _showOrParseArgs =@@ -539,14 +517,12 @@     parent = Cabal.buildCommand defaultProgramConfiguration  instance Monoid BuildExFlags where-  mempty = BuildExFlags {-    buildOnly    = mempty-  }-  mappend a b = BuildExFlags {-    buildOnly    = combine buildOnly-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup BuildExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Repl command -- ------------------------------------------------------------@@ -737,9 +713,7 @@       ++ "\n"       ++ "An existing `cabal.config` is ignored and overwritten.\n",     commandNotes        = Nothing,-    commandUsage        = usageAlternatives "freeze" [""-                                                     ,"PACKAGES"-                                                     ],+    commandUsage        = usageFlags "freeze",     commandDefaultFlags = defaultFreezeFlags,     commandOptions      = \ showOrParseArgs -> [          optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })@@ -771,6 +745,22 @@    } +genBoundsCommand :: CommandUI FreezeFlags+genBoundsCommand = CommandUI {+    commandName         = "gen-bounds",+    commandSynopsis     = "Generate dependency bounds.",+    commandDescription  = Just $ \_ -> wrapText $+         "Generates bounds for all dependencies that do not currently have them. "+      ++ "Generated bounds are printed to stdout.  You can then paste them into your .cabal file.\n"+      ++ "\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "gen-bounds",+    commandDefaultFlags = defaultFreezeFlags,+    commandOptions      = \ _ -> [+     optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })+     ]+  }+ -- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------@@ -838,15 +828,46 @@     commandOptions      = \_ -> []   } +uninstallCommand  :: CommandUI (Flag Verbosity)+uninstallCommand = CommandUI {+    commandName         = "uninstall",+    commandSynopsis     = "Warn about 'uninstall' not being implemented.",+    commandDescription  = Nothing,+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }++manpageCommand :: CommandUI (Flag Verbosity)+manpageCommand = CommandUI {+    commandName         = "manpage",+    commandSynopsis     = "Outputs manpage source.",+    commandDescription  = Just $ \_ ->+      "Output manpage source to STDOUT.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "manpage",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }+ runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI {     commandName         = "run",     commandSynopsis     = "Builds and runs an executable.",-    commandDescription  = Just $ \_ -> wrapText $+    commandDescription  = Just $ \pname -> wrapText $          "Builds and then runs the specified executable. If no executable is "       ++ "specified, but the package contains just one executable, that one "-      ++ "is built and executed.\n",-    commandNotes        = Nothing,+      ++ "is built and executed.\n"+      ++ "\n"+      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "+      ++ "test-suite and get its full output.\n",+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " run\n"+       ++ "    Run the only executable in the current package;\n"+       ++ "  " ++ pname ++ " run foo -- --fooflag\n"+       ++ "    Works similar to `./foo --fooflag`.\n",     commandUsage        = usageAlternatives "run"         ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],     commandDefaultFlags = mempty,@@ -871,7 +892,7 @@     reportUsername  :: Flag Username,     reportPassword  :: Flag Password,     reportVerbosity :: Flag Verbosity-  }+  } deriving Generic  defaultReportFlags :: ReportFlags defaultReportFlags = ReportFlags {@@ -907,18 +928,12 @@   }  instance Monoid ReportFlags where-  mempty = ReportFlags {-    reportUsername  = mempty,-    reportPassword  = mempty,-    reportVerbosity = mempty-  }-  mappend a b = ReportFlags {-    reportUsername  = combine reportUsername,-    reportPassword  = combine reportPassword,-    reportVerbosity = combine reportVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ReportFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Get flags -- ------------------------------------------------------------@@ -928,7 +943,7 @@     getPristine         :: Flag Bool,     getSourceRepository :: Flag (Maybe RepoKind),     getVerbosity        :: Flag Verbosity-  }+  } deriving Generic  defaultGetFlags :: GetFlags defaultGetFlags = GetFlags {@@ -947,7 +962,12 @@        ++ "the source\ntarball and unpacks it in a local subdirectory. "        ++ "Alternatively, with -s it will\nget the code from the source "        ++ "repository specified by the package.\n",-    commandNotes        = Nothing,+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " get hlint\n"+       ++ "    Download the latest stable version of hlint;\n"+       ++ "  " ++ pname ++ " get lens --source-repository=head\n"+       ++ "    Download the source repository (i.e. git clone from github).\n",     commandUsage        = usagePackages "get",     commandDefaultFlags = defaultGetFlags,     commandOptions      = \_ -> [@@ -982,20 +1002,12 @@   }  instance Monoid GetFlags where-  mempty = GetFlags {-    getDestDir          = mempty,-    getPristine         = mempty,-    getSourceRepository = mempty,-    getVerbosity        = mempty-    }-  mappend a b = GetFlags {-    getDestDir          = combine getDestDir,-    getPristine         = combine getPristine,-    getSourceRepository = combine getSourceRepository,-    getVerbosity        = combine getVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup GetFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * List flags -- ------------------------------------------------------------@@ -1005,7 +1017,7 @@     listSimpleOutput :: Flag Bool,     listVerbosity    :: Flag Verbosity,     listPackageDBs   :: [Maybe PackageDB]-  }+  } deriving Generic  defaultListFlags :: ListFlags defaultListFlags = ListFlags {@@ -1027,7 +1039,10 @@       ++ "config:ignore-sandbox is False, use the sandbox package database. "       ++ "Otherwise, use the package database specified with --package-db. "       ++ "If not specified, use the user package database.\n",-    commandNotes        = Nothing,+    commandNotes        = Just $ \pname ->+         "Examples:\n"+      ++ "  " ++ pname ++ " list pandoc\n"+      ++ "    Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",     commandUsage        = usageAlternatives "list" [ "[FLAGS]"                                                    , "[FLAGS] STRINGS"],     commandDefaultFlags = defaultListFlags,@@ -1045,7 +1060,12 @@             trueArg          , option "" ["package-db"]-          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          (   "Append the given package database to the list of package"+           ++ " databases used (to satisfy dependencies and register into)."+           ++ " May be a specific file, 'global' or 'user'. The initial list"+           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+           ++ " depending on context. Use 'clear' to reset the list to empty."+           ++ " See the user guide for details.")           listPackageDBs (\v flags -> flags { listPackageDBs = v })           (reqArg' "DB" readPackageDbList showPackageDbList) @@ -1053,20 +1073,12 @@   }  instance Monoid ListFlags where-  mempty = ListFlags {-    listInstalled    = mempty,-    listSimpleOutput = mempty,-    listVerbosity    = mempty,-    listPackageDBs   = mempty-    }-  mappend a b = ListFlags {-    listInstalled    = combine listInstalled,-    listSimpleOutput = combine listSimpleOutput,-    listVerbosity    = combine listVerbosity,-    listPackageDBs   = combine listPackageDBs-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ListFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Info flags -- ------------------------------------------------------------@@ -1074,7 +1086,7 @@ data InfoFlags = InfoFlags {     infoVerbosity  :: Flag Verbosity,     infoPackageDBs :: [Maybe PackageDB]-  }+  } deriving Generic  defaultInfoFlags :: InfoFlags defaultInfoFlags = InfoFlags {@@ -1098,7 +1110,12 @@         optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })          , option "" ["package-db"]-          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          (   "Append the given package database to the list of package"+           ++ " databases used (to satisfy dependencies and register into)."+           ++ " May be a specific file, 'global' or 'user'. The initial list"+           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+           ++ " depending on context. Use 'clear' to reset the list to empty."+           ++ " See the user guide for details.")           infoPackageDBs (\v flags -> flags { infoPackageDBs = v })           (reqArg' "DB" readPackageDbList showPackageDbList) @@ -1106,16 +1123,12 @@   }  instance Monoid InfoFlags where-  mempty = InfoFlags {-    infoVerbosity  = mempty,-    infoPackageDBs = mempty-    }-  mappend a b = InfoFlags {-    infoVerbosity  = combine infoVerbosity,-    infoPackageDBs = combine infoPackageDBs-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup InfoFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------@@ -1145,9 +1158,13 @@     installSymlinkBinDir    :: Flag FilePath,     installOneShot          :: Flag Bool,     installNumJobs          :: Flag (Maybe Int),-    installRunTests         :: Flag Bool+    installRunTests         :: Flag Bool,+    installOfflineMode      :: Flag Bool   }+  deriving (Eq, Generic) +instance Binary InstallFlags+ defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags {     installDocumentation   = Flag False,@@ -1172,33 +1189,13 @@     installSymlinkBinDir   = mempty,     installOneShot         = Flag False,     installNumJobs         = mempty,-    installRunTests        = mempty+    installRunTests        = mempty,+    installOfflineMode     = Flag False   }   where     docIndexFile = toPathTemplate ("$datadir" </> "doc"                                    </> "$arch-$os-$compiler" </> "index.html") -allowNewerParser :: ReadE AllowNewer-allowNewerParser = ReadE $ \s ->-  case s of-    ""      -> Right AllowNewerNone-    "False" -> Right AllowNewerNone-    "True"  -> Right AllowNewerAll-    _       ->-      case readPToMaybe pkgsParser s of-        Just pkgs -> Right . AllowNewerSome $ pkgs-        Nothing   -> Left ("Cannot parse the list of packages: " ++ s)-  where-    pkgsParser = Parse.sepBy1 parse (Parse.char ',')--allowNewerPrinter :: Flag AllowNewer -> [Maybe String]-allowNewerPrinter (Flag AllowNewerNone)        = [Just "False"]-allowNewerPrinter (Flag AllowNewerAll)         = [Just "True"]-allowNewerPrinter (Flag (AllowNewerSome pkgs)) =-  [Just . intercalate "," . map display $ pkgs]-allowNewerPrinter NoFlag                       = []-- defaultMaxBackjumps :: Int defaultMaxBackjumps = 2000 @@ -1230,11 +1227,24 @@      ++ " that, `configure` must be used.)\n"      ++ " In contrast, without a sandbox, the flags to `install` are saved and"      ++ " affect future commands such as `build` and `repl`. See the help for"-     ++ " `configure` for a list of commands being affected.\n",+     ++ " `configure` for a list of commands being affected.\n"+     ++ "\n"+     ++ "Installed executables will by default (and without a sandbox)"+     ++ " be put into `~/.cabal/bin/`."+     ++ " If you want installed executable to be available globally, make"+     ++ " sure that the PATH environment variable contains that directory.\n"+     ++ "When using a sandbox, executables will be put into"+     ++ " `$SANDBOX/bin/` (by default: `./.cabal-sandbox/bin/`).\n"+     ++ "\n"+     ++ "When specifying --bindir, consider also specifying --datadir;"+     ++ " this way the sandbox can be deleted and the executable should"+     ++ " continue working as long as bindir and datadir are left untouched.",   commandNotes        = Just $ \pname ->-        ( case commandNotes configureCommand of-            Just desc -> desc pname ++ "\n"-            Nothing   -> "" )+        ( case commandNotes+               $ Cabal.configureCommand defaultProgramConfiguration+          of Just desc -> desc pname ++ "\n"+             Nothing   -> ""+        )      ++ "Examples:\n"      ++ "  " ++ pname ++ " install                 "      ++ "    Package in the current directory\n"@@ -1243,7 +1253,11 @@      ++ "  " ++ pname ++ " install foo-1.0         "      ++ "    Specific version of a package\n"      ++ "  " ++ pname ++ " install 'foo < 2'       "-     ++ "    Constrained package version\n",+     ++ "    Constrained package version\n"+     ++ "  " ++ pname ++ " install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"+     ++ "  " ++ (map (const ' ') pname)+                      ++ "                         "+     ++ "    Change installation destination\n",   commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->        liftOptions get1 set1@@ -1251,7 +1265,7 @@                            , "exact-configuration"])                 . optionName) $                               configureOptions   showOrParseArgs)-    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)     ++ liftOptions get3 set3 (installOptions     showOrParseArgs)     ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)   }@@ -1383,6 +1397,10 @@       , optionNumJobs         installNumJobs (\v flags -> flags { installNumJobs = v }) +      , option [] ["offline"]+          "Don't download packages from the Internet."+          installOfflineMode (\v flags -> flags { installOfflineMode = v })+          (yesNoOpt showOrParseArgs)       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"                                         -- avoids           ParseArgs ->@@ -1394,81 +1412,39 @@   instance Monoid InstallFlags where-  mempty = InstallFlags {-    installDocumentation   = mempty,-    installHaddockIndex    = mempty,-    installDryRun          = mempty,-    installReinstall       = mempty,-    installAvoidReinstalls = mempty,-    installOverrideReinstall = mempty,-    installMaxBackjumps    = mempty,-    installUpgradeDeps     = mempty,-    installReorderGoals    = mempty,-    installIndependentGoals= mempty,-    installShadowPkgs      = mempty,-    installStrongFlags     = mempty,-    installOnly            = mempty,-    installOnlyDeps        = mempty,-    installRootCmd         = mempty,-    installSummaryFile     = mempty,-    installLogFile         = mempty,-    installBuildReports    = mempty,-    installReportPlanningFailure = mempty,-    installSymlinkBinDir   = mempty,-    installOneShot         = mempty,-    installNumJobs         = mempty,-    installRunTests        = mempty-  }-  mappend a b = InstallFlags {-    installDocumentation   = combine installDocumentation,-    installHaddockIndex    = combine installHaddockIndex,-    installDryRun          = combine installDryRun,-    installReinstall       = combine installReinstall,-    installAvoidReinstalls = combine installAvoidReinstalls,-    installOverrideReinstall = combine installOverrideReinstall,-    installMaxBackjumps    = combine installMaxBackjumps,-    installUpgradeDeps     = combine installUpgradeDeps,-    installReorderGoals    = combine installReorderGoals,-    installIndependentGoals= combine installIndependentGoals,-    installShadowPkgs      = combine installShadowPkgs,-    installStrongFlags     = combine installStrongFlags,-    installOnly            = combine installOnly,-    installOnlyDeps        = combine installOnlyDeps,-    installRootCmd         = combine installRootCmd,-    installSummaryFile     = combine installSummaryFile,-    installLogFile         = combine installLogFile,-    installBuildReports    = combine installBuildReports,-    installReportPlanningFailure = combine installReportPlanningFailure,-    installSymlinkBinDir   = combine installSymlinkBinDir,-    installOneShot         = combine installOneShot,-    installNumJobs         = combine installNumJobs,-    installRunTests        = combine installRunTests-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup InstallFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Upload flags -- ------------------------------------------------------------  data UploadFlags = UploadFlags {-    uploadCheck     :: Flag Bool,-    uploadUsername  :: Flag Username,-    uploadPassword  :: Flag Password,-    uploadVerbosity :: Flag Verbosity-  }+    uploadCheck       :: Flag Bool,+    uploadDoc         :: Flag Bool,+    uploadUsername    :: Flag Username,+    uploadPassword    :: Flag Password,+    uploadPasswordCmd :: Flag [String],+    uploadVerbosity   :: Flag Verbosity+  } deriving Generic  defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags {-    uploadCheck     = toFlag False,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = toFlag normal+    uploadCheck       = toFlag False,+    uploadDoc         = toFlag False,+    uploadUsername    = mempty,+    uploadPassword    = mempty,+    uploadPasswordCmd = mempty,+    uploadVerbosity   = toFlag normal   }  uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI {     commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage.",+    commandSynopsis     = "Uploads source packages or documentation to Hackage.",     commandDescription  = Nothing,     commandNotes        = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n"@@ -1484,6 +1460,11 @@         uploadCheck (\v flags -> flags { uploadCheck = v })         trueArg +      ,option ['d'] ["documentation"]+        "Upload documentation instead of a source package. Cannot be used together with --check."+        uploadDoc (\v flags -> flags { uploadDoc = v })+        trueArg+       ,option ['u'] ["username"]         "Hackage username."         uploadUsername (\v flags -> flags { uploadUsername = v })@@ -1495,24 +1476,21 @@         uploadPassword (\v flags -> flags { uploadPassword = v })         (reqArg' "PASSWORD" (toFlag . Password)                             (flagToList . fmap unPassword))++      ,option ['P'] ["password-command"]+        "Command to get Hackage password."+        uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v })+        (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))       ]   }  instance Monoid UploadFlags where-  mempty = UploadFlags {-    uploadCheck     = mempty,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = mempty-  }-  mappend a b = UploadFlags {-    uploadCheck     = combine uploadCheck,-    uploadUsername  = combine uploadUsername,-    uploadPassword  = combine uploadPassword,-    uploadVerbosity = combine uploadVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup UploadFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Init flags -- ------------------------------------------------------------@@ -1708,7 +1686,7 @@ data SDistExFlags = SDistExFlags {     sDistFormat    :: Flag ArchiveFormat   }-  deriving Show+  deriving (Show, Generic)  data ArchiveFormat = TargzFormat | ZipFormat -- | ...   deriving (Show, Eq)@@ -1741,22 +1719,19 @@       ]  instance Monoid SDistExFlags where-  mempty = SDistExFlags {-    sDistFormat  = mempty-  }-  mappend a b = SDistExFlags {-    sDistFormat  = combine sDistFormat-  }-    where-      combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup SDistExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Win32SelfUpgrade flags -- ------------------------------------------------------------  data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags {   win32SelfUpgradeVerbosity :: Flag Verbosity-}+} deriving Generic  defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags {@@ -1779,15 +1754,52 @@ }  instance Monoid Win32SelfUpgradeFlags where-  mempty      = Win32SelfUpgradeFlags {-    win32SelfUpgradeVerbosity = mempty-    }-  mappend a b = Win32SelfUpgradeFlags {-    win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup Win32SelfUpgradeFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------+-- * ActAsSetup flags+-- ------------------------------------------------------------++data ActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType :: Flag BuildType+} deriving Generic++defaultActAsSetupFlags :: ActAsSetupFlags+defaultActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType = toFlag Simple+}++actAsSetupCommand :: CommandUI ActAsSetupFlags+actAsSetupCommand = CommandUI {+  commandName         = "act-as-setup",+  commandSynopsis     = "Run as-if this was a Setup.hs",+  commandDescription  = Nothing,+  commandNotes        = Nothing,+  commandUsage        = \pname ->+    "Usage: " ++ pname ++ " act-as-setup\n",+  commandDefaultFlags = defaultActAsSetupFlags,+  commandOptions      = \_ ->+      [option "" ["build-type"]+         "Use the given build type."+         actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })+         (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++)+                               (fmap toFlag parse))+                              (map display . flagToList))+      ]+}++instance Monoid ActAsSetupFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ActAsSetupFlags where+  (<>) = gmappend++-- ------------------------------------------------------------ -- * Sandbox-related flags -- ------------------------------------------------------------ @@ -1796,7 +1808,7 @@   sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only                                  -- flag.   sandboxLocation  :: Flag FilePath-}+} deriving Generic  defaultSandboxLocation :: FilePath defaultSandboxLocation = ".cabal-sandbox"@@ -1825,17 +1837,17 @@       ++ " commands, e.g. `repl`, `build`, `exec`."     , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox"       ++ " in folders above the current one, so cabal will not see the sandbox"-      ++ " if you are in a subfolder of a sandboxes."+      ++ " if you are in a subfolder of a sandbox."     , paragraph "Subcommands:"     , headLine "init:"     , indentParagraph $ "Initialize a sandbox in the current directory."       ++ " An existing package database will not be modified, but settings"-      ++ " (such as the location of the database) can be modified this way." +      ++ " (such as the location of the database) can be modified this way."     , headLine "delete:"     , indentParagraph $ "Remove the sandbox; deleting all the packages"       ++ " installed inside."     , headLine "add-source:"-    , indentParagraph $ "Make one or more local package available in the"+    , indentParagraph $ "Make one or more local packages available in the"       ++ " sandbox. PATHS may be relative or absolute."       ++ " Typical usecase is when you need"       ++ " to make a (temporary) modification to a dependency: You download"@@ -1859,9 +1871,23 @@       ++ " installed in the sandbox. For subcommands, see the help for"       ++ " ghc-pkg. Affected by the compiler version specified by `configure`."     ],-  commandNotes        = Just $ \_ ->+  commandNotes        = Just $ \pname ->        relevantConfigValuesText ["require-sandbox"-                                ,"ignore-sandbox"],+                                ,"ignore-sandbox"]+    ++ "\n"+    ++ "Examples:\n"+    ++ "  Set up a sandbox with one local dependency, located at ../foo:\n"+    ++ "    " ++ pname ++ " sandbox init\n"+    ++ "    " ++ pname ++ " sandbox add-source ../foo\n"+    ++ "    " ++ pname ++ " install --only-dependencies\n"+    ++ "  Reset the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox delete\n"+    ++ "    " ++ pname ++ " sandbox init\n"+    ++ "    " ++ pname ++ " install --only-dependencies\n"+    ++ "  List the packages in the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox hc-pkg list\n"+    ++ "  Unregister the `broken` package from the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox hc-pkg -- --force unregister broken\n",   commandUsage        = usageAlternatives "sandbox"     [ "init          [FLAGS]"     , "delete        [FLAGS]"@@ -1889,25 +1915,19 @@   }  instance Monoid SandboxFlags where-  mempty = SandboxFlags {-    sandboxVerbosity = mempty,-    sandboxSnapshot  = mempty,-    sandboxLocation  = mempty-    }-  mappend a b = SandboxFlags {-    sandboxVerbosity = combine sandboxVerbosity,-    sandboxSnapshot  = combine sandboxSnapshot,-    sandboxLocation  = combine sandboxLocation-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup SandboxFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Exec Flags -- ------------------------------------------------------------  data ExecFlags = ExecFlags {   execVerbosity :: Flag Verbosity-}+} deriving Generic  defaultExecFlags :: ExecFlags defaultExecFlags = ExecFlags {@@ -1934,20 +1954,20 @@     ++ " has more control and can, for example, execute custom scripts which"     ++ " indirectly execute GHC.\n"     ++ "\n"-    ++ "See `" ++ pname ++ " sandbox`.",+    ++ "Note that `" ++ pname ++ " repl` is different from `" ++ pname+    ++ " exec -- ghci` as the latter will not forward any additional flags"+    ++ " being defined in the local package to ghci.\n"+    ++ "\n"+    ++ "See `" ++ pname ++ " sandbox`.\n",   commandNotes        = Just $ \pname ->        "Examples:\n"-    ++ "  Install the executable package pandoc into a sandbox and run it:\n"-    ++ "    " ++ pname ++ " sandbox init\n"-    ++ "    " ++ pname ++ " install pandoc\n"-    ++ "    " ++ pname ++ " exec pandoc foo.md\n\n"-    ++ "  Install the executable package hlint into the user package database\n"-    ++ "  and run it:\n"-    ++ "    " ++ pname ++ " install --user hlint\n"-    ++ "    " ++ pname ++ " exec hlint Foo.hs\n\n"-    ++ "  Execute runghc on Foo.hs with runghc configured to use the\n"-    ++ "  sandbox package database (if a sandbox is being used):\n"-    ++ "    " ++ pname ++ " exec runghc Foo.hs\n",+    ++ "  " ++ pname ++ " exec -- ghci -Wall\n"+    ++ "    Start a repl session with sandbox packages and all warnings;\n"+    ++ "  " ++ pname ++ " exec gitit -- -f gitit.cnf\n"+    ++ "    Give gitit access to the sandbox packages, and pass it a flag;\n"+    ++ "  " ++ pname ++ " exec runghc Foo.hs\n"+    ++ "    Execute runghc on Foo.hs with runghc configured to use the\n"+    ++ "    sandbox package database (if a sandbox is being used).\n",   commandUsage        = \pname ->        "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n", @@ -1959,31 +1979,31 @@   }  instance Monoid ExecFlags where-  mempty = ExecFlags {-    execVerbosity = mempty-    }-  mappend a b = ExecFlags {-    execVerbosity = combine execVerbosity-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ExecFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * UserConfig flags -- ------------------------------------------------------------  data UserConfigFlags = UserConfigFlags {-  userConfigVerbosity :: Flag Verbosity-}+  userConfigVerbosity :: Flag Verbosity,+  userConfigForce     :: Flag Bool+} deriving Generic  instance Monoid UserConfigFlags where   mempty = UserConfigFlags {-    userConfigVerbosity = toFlag normal-    }-  mappend a b = UserConfigFlags {-    userConfigVerbosity = combine userConfigVerbosity+    userConfigVerbosity = toFlag normal,+    userConfigForce     = toFlag False     }-    where combine field = field a `mappend` field b+  mappend = (<>) +instance Semigroup UserConfigFlags where+  (<>) = gmappend+ userConfigCommand :: CommandUI UserConfigFlags userConfigCommand = CommandUI {   commandName         = "user-config",@@ -1995,6 +2015,9 @@     ++ " (i.e. all bindings that are actually defined and not commented out)"     ++ " and the default config of the new version.\n"     ++ "\n"+    ++ "init: Creates a new config file at either ~/.cabal/config or as"+    ++ " specified by --config-file, if given. An existing file won't be "+    ++ " overwritten unless -f or --force is given.\n"     ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and"     ++ " the default configuration that would be created by cabal if the"     ++ " config file did not exist.\n"@@ -2002,10 +2025,14 @@     ++ " created by default, and write the result back to ~/.cabal/config.",    commandNotes        = Nothing,-  commandUsage        = usageAlternatives "user-config" ["diff", "update"],+  commandUsage        = usageAlternatives "user-config" ["init", "diff", "update"],   commandDefaultFlags = mempty,   commandOptions      = \ _ -> [    optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })+ , option ['f'] ["force"]+     "Overwrite the config file if it already exists."+     userConfigForce (\v flags -> flags { userConfigForce = v })+     trueArg    ]   } @@ -2047,8 +2074,7 @@   [ option [] ["max-backjumps"]       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")       getmbj setmbj-      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++)-                                (fmap toFlag (Parse.readS_to_P reads)))+      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse))                     (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."@@ -2096,10 +2122,6 @@          show arg ++ " is not valid syntax for a package name or"                   ++ " package dependency." -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                     , all isSpace s ]- parseDependencyOrPackageId :: Parse.ReadP r Dependency parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse   where@@ -2117,13 +2139,17 @@  parseRepo :: Parse.ReadP r RemoteRepo parseRepo = do-  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")-  _ <- Parse.char ':'+  name   <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+  _      <- Parse.char ':'   uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")-  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)-  return $ RemoteRepo {-    remoteRepoName = name,-    remoteRepoURI  = uri+  uri    <- maybe Parse.pfail return (parseAbsoluteURI uriStr)+  return RemoteRepo {+    remoteRepoName           = name,+    remoteRepoURI            = uri,+    remoteRepoSecure         = Nothing,+    remoteRepoRootKeys       = [],+    remoteRepoKeyThreshold   = 0,+    remoteRepoShouldTryHttps = False   }  -- ------------------------------------------------------------@@ -2145,6 +2171,7 @@  indentParagraph :: String -> String indentParagraph = unlines+                . (flip (++)) [""]                 . map (("  "++).unwords)                 . wrapLine 77                 . words
Distribution/Client/SetupWrapper.hs view
@@ -27,9 +27,9 @@          ( Version(..), VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )-import Distribution.InstalledPackageInfo (installedPackageId)+import Distribution.InstalledPackageInfo (installedUnitId) import Distribution.Package-         ( InstalledPackageId(..), PackageIdentifier(..),+         ( UnitId(..), PackageIdentifier(..), PackageId,            PackageName(..), Package(..), packageName          , packageVersion, Dependency(..) ) import Distribution.PackageDescription@@ -46,6 +46,8 @@          ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) import Distribution.Simple.PreProcess          ( runSimplePreProcessor, ppUnlit )+import Distribution.Simple.Build.Macros+         ( generatePackageVersionMacros ) import Distribution.Simple.Program          ( ProgramConfiguration, emptyProgramConfiguration          , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram@@ -57,6 +59,7 @@ import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.BuildPaths          ( defaultDistPref, exeExtension )+ import Distribution.Simple.Command          ( CommandUI(..), commandShowOptions ) import Distribution.Simple.Program.GHC@@ -99,14 +102,13 @@ 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           ( foldl1' ) import Data.Maybe          ( fromMaybe, isJust )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid         ( mempty )-#endif import Data.Char           ( isSpace )+import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )  #ifdef mingw32_HOST_OS import Distribution.Simple.Utils@@ -118,8 +120,37 @@ import qualified System.Win32 as Win32 #endif +--TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two+-- parts: one that has no policy and just does as it's told with all the+-- explicit options, and an optional initial part that applies certain+-- policies (like if we should add the Cabal lib as a dep, and if so which+-- version). This could be structured as an action that returns a fully+-- elaborated 'SetupScriptOptions' containing no remaining policy choices.+--+-- See also the discussion at https://github.com/haskell/cabal/pull/3094+ data SetupScriptOptions = SetupScriptOptions {+    -- | The version of the Cabal library to use (if 'useDependenciesExclusive'+    -- is not set). A suitable version of the Cabal library must be installed+    -- (or for some build-types be the one cabal-install was built with).+    --+    -- The version found also determines the version of the Cabal specification+    -- that we us for talking to the Setup.hs, unless overridden by+    -- 'useCabalSpecVersion'.+    --     useCabalVersion          :: VersionRange,++    -- | This is the version of the Cabal specification that we believe that+    -- this package uses. This affects the semantics and in particular the+    -- Setup command line interface.+    --+    -- This is similar to 'useCabalVersion' but instead of probing the system+    -- for a version of the /Cabal library/ you just say exactly which version+    -- of the /spec/ we will use. Using this also avoid adding the Cabal+    -- library as an additional dependency, so add it to 'useDependencies'+    -- if needed.+    --+    useCabalSpecVersion      :: Maybe Version,     useCompiler              :: Maybe Compiler,     usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,@@ -130,6 +161,31 @@     useWorkingDir            :: Maybe FilePath,     forceExternalSetupMethod :: Bool, +    -- | List of dependencies to use when building Setup.hs.+    useDependencies :: [(UnitId, PackageId)],++    -- | Is the list of setup dependencies exclusive?+    --+    -- When this is @False@, if we compile the Setup.hs script we do so with the+    -- list in 'useDependencies' but all other packages in the environment are+    -- also visible. A suitable version of @Cabal@ library (see+    -- 'useCabalVersion') is also added to the list of dependencies, unless+    -- 'useDependencies' already contains a Cabal dependency.+    --+    -- When @True@, only the 'useDependencies' packages are used, with other+    -- packages in the environment hidden.+    --+    -- This feature is here to support the setup stanza in .cabal files that+    -- specifies explicit (and exclusive) dependencies, as well as the old+    -- style with no dependencies.+    useDependenciesExclusive :: Bool,++    -- | Should we build the Setup.hs with CPP version macros available?+    -- We turn this on when we have a setup stanza in .cabal that declares+    -- explicit setup dependencies.+    --+    useVersionMacros         :: Bool,+     -- Used only by 'cabal clean' on Windows.     --     -- Note: win32 clean hack@@ -159,10 +215,14 @@ defaultSetupScriptOptions :: SetupScriptOptions defaultSetupScriptOptions = SetupScriptOptions {     useCabalVersion          = anyVersion,+    useCabalSpecVersion      = Nothing,     useCompiler              = Nothing,     usePlatform              = Nothing,     usePackageDB             = [GlobalPackageDB, UserPackageDB],     usePackageIndex          = Nothing,+    useDependencies          = [],+    useDependenciesExclusive = False,+    useVersionMacros         = False,     useProgramConfig         = emptyProgramConfiguration,     useDistPref              = defaultDistPref,     useLoggingHandle         = Nothing,@@ -209,12 +269,24 @@ -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType'-  | forceExternalSetupMethod options = externalSetupMethod+    -- 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   | isJust (useLoggingHandle options)- || buildType' == Custom             = externalSetupMethod-  | cabalVersion `withinRange`-      useCabalVersion options        = internalSetupMethod-  | otherwise                        = externalSetupMethod+    -- Forcing is done to use an external process e.g. due to parallel+    -- build concerns.+ || forceExternalSetupMethod options = selfExecSetupMethod+  | otherwise                        = internalSetupMethod  type SetupMethod = Verbosity                 -> SetupScriptOptions@@ -243,12 +315,42 @@ buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"  -- ------------------------------------------------------------+-- * Self-Exec SetupMethod+-- ------------------------------------------------------------++selfExecSetupMethod :: SetupMethod+selfExecSetupMethod verbosity options _pkg bt mkargs = do+  let args = ["act-as-setup",+              "--build-type=" ++ display bt,+              "--"] ++ mkargs cabalVersion+  debug verbosity $ "Using self-exec internal setup method with build-type "+                 ++ show bt ++ " and args:\n  " ++ show args+  path <- getExecutablePath+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing        -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to "+                                    ++ show logHandle++  searchpath <- programSearchPathAsPATHVar+                (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++-- ------------------------------------------------------------ -- * External SetupMethod -- ------------------------------------------------------------  externalSetupMethod :: SetupMethod externalSetupMethod verbosity options pkg bt mkargs = do   debug verbosity $ "Using external setup method with build-type " ++ show bt+  debug verbosity $ "Using explicit dependencies: "+    ++ show (useDependenciesExclusive options)   createDirectoryIfMissingVerbose verbosity True setupDir   (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion@@ -272,27 +374,33 @@   useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)    maybeGetInstalledPackages :: SetupScriptOptions -> Compiler-                               -> ProgramConfiguration -> IO InstalledPackageIndex+                            -> ProgramConfiguration -> IO InstalledPackageIndex   maybeGetInstalledPackages options' comp conf =     case usePackageIndex options' of       Just index -> return index       Nothing    -> getInstalledPackages verbosity                     comp (usePackageDB options') conf -  cabalLibVersionToUse :: IO (Version, (Maybe InstalledPackageId)+  cabalLibVersionToUse :: IO (Version, (Maybe UnitId)                              ,SetupScriptOptions)-  cabalLibVersionToUse = do-    savedVer <- savedVersion-    case savedVer of-      Just version | version `withinRange` useCabalVersion options-        -> do updateSetupScript version bt-              -- Does the previously compiled setup executable still exist and-              -- is it up-to date?-              useExisting <- canUseExistingSetup version-              if useExisting-                then return (version, Nothing, options)-                else installedVersion-      _ -> installedVersion+  cabalLibVersionToUse =+    case useCabalSpecVersion options of+      Just version -> do+        updateSetupScript version bt+        writeFile setupVersionFile (show version ++ "\n")+        return (version, Nothing, options)+      Nothing  -> do+        savedVer <- savedVersion+        case savedVer of+          Just version | version `withinRange` useCabalVersion options+            -> do updateSetupScript version bt+                  -- Does the previously compiled setup executable still exist+                  -- and is it up-to date?+                  useExisting <- canUseExistingSetup version+                  if useExisting+                    then return (version, Nothing, options)+                    else installedVersion+          _ -> installedVersion     where       -- This check duplicates the checks in 'getCachedSetupExecutable' /       -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice@@ -308,7 +416,7 @@           (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs                <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile -      installedVersion :: IO (Version, Maybe InstalledPackageId+      installedVersion :: IO (Version, Maybe UnitId                              ,SetupScriptOptions)       installedVersion = do         (comp,    conf,    options')  <- configureCompiler options@@ -355,7 +463,7 @@     UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"    installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration-                        -> IO (Version, Maybe InstalledPackageId+                        -> IO (Version, Maybe UnitId                               ,SetupScriptOptions)   installedCabalVersion options' compiler conf = do     index <- maybeGetInstalledPackages options' compiler conf@@ -368,7 +476,7 @@                  ++ " but no suitable version is installed."       pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs               in return (packageVersion ipkginfo-                        ,Just . installedPackageId $ ipkginfo, options'')+                        ,Just . installedUnitId $ ipkginfo, options'')    bestVersion :: (a -> Version) -> [a] -> a   bestVersion f = firstMaximumBy (comparing (preference . f))@@ -441,7 +549,7 @@   -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.   getCachedSetupExecutable :: SetupScriptOptions-                           -> Version -> Maybe InstalledPackageId+                           -> Version -> Maybe UnitId                            -> IO FilePath   getCachedSetupExecutable options' cabalLibVersion                            maybeCabalLibInstalledPkgId = do@@ -476,7 +584,7 @@   -- Currently this is GHC/GHCJS only. It should really be generalised.   --   compileSetupExecutable :: SetupScriptOptions-                         -> Version -> Maybe InstalledPackageId -> Bool+                         -> Version -> Maybe UnitId -> Bool                          -> IO FilePath   compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId                          forceCompile = do@@ -491,6 +599,30 @@             = case compilerFlavor compiler of                       GHCJS -> (ghcjsProgram, ["-build-runner"])                       _     -> (ghcProgram,   ["-threaded"])+          cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])+                              maybeCabalLibInstalledPkgId++          -- With 'useDependenciesExclusive' we enforce the deps specified,+          -- so only the given ones can be used. Otherwise we allow the use+          -- of packages in the ambient environment, and add on a dep on the+          -- Cabal library (unless 'useDependencies' already contains one).+          --+          -- With 'useVersionMacros' we use a version CPP macros .h file.+          --+          -- Both of these options should be enabled for packages that have+          -- opted-in and declared a custom-settup stanza.+          --+          hasCabal (_, PackageIdentifier (PackageName "Cabal") _) = True+          hasCabal _                                              = False++          selectedDeps | useDependenciesExclusive options'+                                   = useDependencies options'+                       | otherwise = useDependencies options' +++                                     if any hasCabal (useDependencies options')+                                     then []+                                     else cabalDep+          addRenaming (ipid, pid) = (ipid, pid, defaultRenaming)+          cppMacrosFile = setupDir </> "setup_macros.h"           ghcOptions = mempty {               ghcOptVerbosity       = Flag verbosity             , ghcOptMode            = Flag GhcModeMake@@ -503,12 +635,17 @@                                       Custom -> toNubListR [workingDir]                                       _      -> mempty             , ghcOptPackageDBs      = usePackageDB options''-            , ghcOptPackages        = toNubListR $-                maybe [] (\ipkgid -> [(ipkgid, cabalPkgid, defaultRenaming)])-                maybeCabalLibInstalledPkgId+            , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')+            , ghcOptCabal           = Flag (useDependenciesExclusive options')+            , ghcOptPackages        = toNubListR $ map addRenaming selectedDeps+            , ghcOptCppIncludes     = toNubListR [ cppMacrosFile+                                                 | useVersionMacros options' ]             , ghcOptExtra           = toNubListR extraOpts             }-      let ghcCmdLine = renderGhcOptions compiler ghcOptions+      let ghcCmdLine = renderGhcOptions compiler platform ghcOptions+      when (useVersionMacros options') $+        rewriteFile cppMacrosFile (generatePackageVersionMacros+                                     [ pid | (_ipid, pid) <- selectedDeps ])       case useLoggingHandle options of         Nothing          -> runDbProgram verbosity program conf ghcCmdLine
Distribution/Client/SrcDist.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE NondecreasingIndentation #-} -- 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. module Distribution.Client.SrcDist (-         sdist+         sdist,+         allPackageSourceFiles   )  where  @@ -11,7 +13,7 @@ import Distribution.Client.Tar (createTarGzFile)  import Distribution.Package-         ( Package(..) )+         ( Package(..), packageName ) import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Configuration@@ -20,30 +22,35 @@          ( readPackageDescription ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, defaultPackageDesc-         , die, notice, withTempDirectory )+         , warn, die, notice, withTempDirectory ) import Distribution.Client.Setup          ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup-         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault )+         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault+         , defaultSDistFlags ) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display )-import Distribution.Verbosity (Verbosity)+import Distribution.Verbosity (Verbosity, normal, lessVerbose) import Distribution.Version   (Version(..), orLaterVersion) +import Distribution.Client.Utils+  (tryFindAddSourcePackageDesc)+import Distribution.Compat.Exception                 (catchIO)+ import System.FilePath ((</>), (<.>))-import Control.Monad (when, unless)-import System.Directory (doesFileExist, removeFile, canonicalizePath)+import Control.Monad (when, unless, liftM)+import System.Directory (doesFileExist, removeFile, canonicalizePath, getTemporaryDirectory) import System.Process (runProcess, waitForProcess) import System.Exit    (ExitCode(..))+import Control.Exception                             (IOException, evaluate)  -- |Create a source distribution. sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do-  pkg <- return . flattenPackageDescription-         =<< readPackageDescription verbosity-         =<< defaultPackageDesc verbosity+  pkg <- liftM flattenPackageDescription+    (readPackageDescription verbosity =<< defaultPackageDesc verbosity)   let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)                 else withTempDirectory verbosity tmpTargetDir "sdist."   -- 'withTempDir' fails if we don't create 'tmpTargetDir'...@@ -137,3 +144,45 @@     notice verbosity $ "Source zip archive created: " ++ zipfile   where     zipProgram = simpleProgram "zip"++-- | 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+  pkg <- do+    let err = "Error reading source files of package."+    desc <- tryFindAddSourcePackageDesc packageDir err+    flattenPackageDescription `fmap` readPackageDescription verbosity desc+  globalTmp <- getTemporaryDirectory+  withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do+  let file      = tempDir </> "cabal-sdist-list-sources"+      flags     = defaultSDistFlags {+        sDistVerbosity   = Flag $ if verbosity == normal+                                  then lessVerbose verbosity else verbosity,+        sDistListSources = Flag file+        }+      setupOpts = defaultSetupScriptOptions {+        -- 'sdist --list-sources' was introduced in Cabal 1.18.+        useCabalVersion = orLaterVersion $ Version [1,18,0] [],+        useWorkingDir = Just packageDir+        }++      doListSources :: IO [FilePath]+      doListSources = do+        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []+        fmap lines . readFile $ file++      onFailedListSources :: IOException -> IO ()+      onFailedListSources e = do+        warn verbosity $+          "Could not list sources of the package '"+          ++ display (packageName pkg) ++ "'."+        warn verbosity $+          "Exception was: " ++ show e++  -- Run setup sdist --list-sources=TMPFILE+  r <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])+  -- Ensure that we've closed the 'readFile' handle before we exit the+  -- temporary directory.+  _ <- evaluate (length r)+  return r
Distribution/Client/Tar.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Tar@@ -15,94 +15,27 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Tar (-  -- * High level \"all in one\" operations+  -- * @tar.gz@ operations   createTarGzFile,   extractTarGzFile, -  -- * Converting between internal and external representation-  read,-  write,-  writeEntries,--  -- * Packing and unpacking files to\/from internal representation-  pack,-  unpack,--  -- * Tar entry and associated types-  Entry(..),-  entryPath,-  EntryContent(..),-  Ownership(..),-  FileSize,-  Permissions,-  EpochTime,-  DevMajor,-  DevMinor,-  TypeCode,-  Format(..),+  -- * Other local utils   buildTreeRefTypeCode,   buildTreeSnapshotTypeCode,   isBuildTreeRefTypeCode,-  entrySizeInBlocks,-  entrySizeInBytes,--  -- * Constructing simple entry values-  simpleEntry,-  fileEntry,-  directoryEntry,--  -- * TarPath type-  TarPath,-  toTarPath,-  fromTarPath,--  -- ** Sequences of tar entries-  Entries(..),-  foldrEntries,-  foldlEntries,-  unfoldrEntries,-  mapEntries,   filterEntries,-  entriesIndex,-+  filterEntriesM,+  entriesToList,   ) where -import Data.Char     (ord)-import Data.Int      (Int64)-import Data.Bits     (Bits, shiftL, testBit)-import Data.List     (foldl')-import Numeric       (readOct, showOct)-import Control.Applicative (Applicative(..))-import Control.Monad (MonadPlus(mplus), when, ap, liftM)-import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy    as BS+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Check as Tar+import qualified Codec.Compression.GZip  as GZip import qualified Distribution.Client.GZipUtils as GZipUtils -import System.FilePath-         ( (</>) )-import qualified System.FilePath         as FilePath.Native-import qualified System.FilePath.Windows as FilePath.Windows-import qualified System.FilePath.Posix   as FilePath.Posix-import System.Directory-         ( getDirectoryContents, doesDirectoryExist-         , getPermissions, createDirectoryIfMissing, copyFile )-import qualified System.Directory as Permissions-         ( Permissions(executable) )-import Distribution.Client.Compat.FilePerms-         ( setFileExecutable )-import System.Posix.Types-         ( FileMode )-import Distribution.Client.Compat.Time-         ( EpochTime, getModTime )-import System.IO-         ( IOMode(ReadMode), openBinaryFile, hFileSize )-import System.IO.Unsafe (unsafeInterleaveIO)--import Prelude hiding (read)-+import Control.Exception (Exception(..), throw)  -- -- * High level operations@@ -113,839 +46,65 @@                 -> FilePath  -- ^ Directory to archive, relative to base dir                 -> IO () createTarGzFile tar base dir =-  BS.writeFile tar . GZip.compress . write =<< pack base [dir]+  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]  extractTarGzFile :: FilePath -- ^ Destination directory                  -> FilePath -- ^ Expected subdir (to check for tarbombs)                  -> FilePath -- ^ Tarball                 -> IO () extractTarGzFile dir expected tar =-  unpack dir . checkTarbomb expected . read+  Tar.unpack dir . Tar.checkTarbomb expected . Tar.read   . GZipUtils.maybeDecompress =<< BS.readFile tar ------ * Entry type---+instance (Exception a, Exception b) => Exception (Either a b) where+  toException (Left  e) = toException e+  toException (Right e) = toException e -type FileSize  = Int64-type DevMajor  = Int-type DevMinor  = Int-type TypeCode  = Char-type Permissions = FileMode+  fromException e =+    case fromException e of+      Just e' -> Just (Left e')+      Nothing -> case fromException e of+                   Just e' -> Just (Right e')+                   Nothing -> Nothing --- | Tar archive entry.----data Entry = Entry { -    -- | The path of the file or directory within the archive. This is in a-    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.-    entryTarPath :: !TarPath,--    -- | The real content of the entry. For 'NormalFile' this includes the-    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.-    entryContent :: !EntryContent,--    -- | File permissions (Unix style file mode).-    entryPermissions :: !Permissions,--    -- | The user and group to which this file belongs.-    entryOwnership :: !Ownership,--    -- | The time the file was last modified.-    entryTime :: !EpochTime,--    -- | The tar format the archive is using.-    entryFormat :: !Format-  }- -- | Type code for the local build tree reference entry type. We don't use the -- symbolic link entry type because it allows only 100 ASCII characters for the -- path.-buildTreeRefTypeCode :: TypeCode+buildTreeRefTypeCode :: Tar.TypeCode buildTreeRefTypeCode = 'C'  -- | Type code for the local build tree snapshot entry type.-buildTreeSnapshotTypeCode :: TypeCode+buildTreeSnapshotTypeCode :: Tar.TypeCode buildTreeSnapshotTypeCode = 'S'  -- | Is this a type code for a build tree reference?-isBuildTreeRefTypeCode :: TypeCode -> Bool+isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool isBuildTreeRefTypeCode typeCode   | (typeCode == buildTreeRefTypeCode      || typeCode == buildTreeSnapshotTypeCode) = True   | otherwise                                  = False --- | Native 'FilePath' of the file or directory within the archive.----entryPath :: Entry -> FilePath-entryPath = fromTarPath . entryTarPath---- | Return the size of an entry in bytes.-entrySizeInBytes :: Entry -> FileSize-entrySizeInBytes = (*512) . fromIntegral . entrySizeInBlocks---- | Return the number of blocks in an entry.-entrySizeInBlocks :: Entry -> Int-entrySizeInBlocks entry = 1 + case entryContent entry of-  NormalFile     _   size -> bytesToBlocks size-  OtherEntryType _ _ size -> bytesToBlocks size-  _                       -> 0-  where-    bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)---- | The content of a tar archive entry, which depends on the type of entry.------ Portable archives should contain only 'NormalFile' and 'Directory'.----data EntryContent = NormalFile      ByteString !FileSize-                  | Directory-                  | SymbolicLink    !LinkTarget-                  | HardLink        !LinkTarget-                  | CharacterDevice !DevMajor !DevMinor-                  | BlockDevice     !DevMajor !DevMinor-                  | NamedPipe-                  | OtherEntryType  !TypeCode ByteString !FileSize--data Ownership = Ownership {-    -- | The owner user name. Should be set to @\"\"@ if unknown.-    ownerName :: String,--    -- | The owner group name. Should be set to @\"\"@ if unknown.-    groupName :: String,--    -- | Numeric owner user id. Should be set to @0@ if unknown.-    ownerId :: !Int,--    -- | Numeric owner group id. Should be set to @0@ if unknown.-    groupId :: !Int-  }---- | There have been a number of extensions to the tar file format over the--- years. They all share the basic entry fields and put more meta-data in--- different extended headers.----data Format =--     -- | This is the classic Unix V7 tar format. It does not support owner and-     -- group names, just numeric Ids. It also does not support device numbers.-     V7Format--     -- | The \"USTAR\" format is an extension of the classic V7 format. It was-     -- later standardised by POSIX. It has some restrictions but is the most-     -- portable format.-     ---   | UstarFormat--     -- | The GNU tar implementation also extends the classic V7 format, though-     -- in a slightly different way from the USTAR format. In general for new-     -- archives the standard USTAR/POSIX should be used.-     ---   | GnuFormat-  deriving Eq---- | @rw-r--r--@ for normal files-ordinaryFilePermissions :: Permissions-ordinaryFilePermissions   = 0o0644---- | @rwxr-xr-x@ for executable files-executableFilePermissions :: Permissions-executableFilePermissions = 0o0755---- | @rwxr-xr-x@ for directories-directoryPermissions :: Permissions-directoryPermissions  = 0o0755--isExecutable :: Permissions -> Bool-isExecutable p = testBit p 0 || testBit p 6 -- user or other executable---- | An 'Entry' with all default values except for the file name and type. It--- uses the portable USTAR/POSIX format (see 'UstarHeader').------ You can use this as a basis and override specific fields, eg:------ > (emptyEntry name HardLink) { linkTarget = target }----simpleEntry :: TarPath -> EntryContent -> Entry-simpleEntry tarpath content = Entry {-    entryTarPath     = tarpath,-    entryContent     = content,-    entryPermissions = case content of-                         Directory -> directoryPermissions-                         _         -> ordinaryFilePermissions,-    entryOwnership   = Ownership "" "" 0 0,-    entryTime        = 0,-    entryFormat      = UstarFormat-  }---- | A tar 'Entry' for a file.------ Entry  fields such as file permissions and ownership have default values.------ You can use this as a basis and override specific fields. For example if you--- need an executable file you could use:------ > (fileEntry name content) { fileMode = executableFileMode }----fileEntry :: TarPath -> ByteString -> Entry-fileEntry name fileContent =-  simpleEntry name (NormalFile fileContent (BS.length fileContent))---- | A tar 'Entry' for a directory.------ Entry fields such as file permissions and ownership have default values.----directoryEntry :: TarPath -> Entry-directoryEntry name = simpleEntry name Directory------- * Tar paths------- | The classic tar format allowed just 100 characters for the file name. The--- USTAR format extended this with an extra 155 characters, however it uses a--- complex method of splitting the name between the two sections.------ Instead of just putting any overflow into the extended area, it uses the--- extended area as a prefix. The aggravating insane bit however is that the--- prefix (if any) must only contain a directory prefix. That is the split--- between the two areas must be on a directory separator boundary. So there is--- no simple calculation to work out if a file name is too long. Instead we--- have to try to find a valid split that makes the name fit in the two areas.------ The rationale presumably was to make it a bit more compatible with old tar--- programs that only understand the classic format. A classic tar would be--- able to extract the file name and possibly some dir prefix, but not the--- full dir prefix. So the files would end up in the wrong place, but that's--- probably better than ending up with the wrong names too.------ So it's understandable but rather annoying.------ * Tar paths use POSIX format (ie @\'/\'@ directory separators), irrespective---   of the local path conventions.------ * The directory separator between the prefix and name is /not/ stored.----data TarPath = TarPath FilePath -- path name, 100 characters max.-                       FilePath -- path prefix, 155 characters max.-  deriving (Eq, Ord)---- | Convert a 'TarPath' to a native 'FilePath'.------ The native 'FilePath' will use the native directory separator but it is not--- otherwise checked for validity or sanity. In particular:------ * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is---   not valid on Windows.------ * The tar path may be an absolute path or may contain @\"..\"@ components.---   For security reasons this should not usually be allowed, but it is your---   responsibility to check for these conditions (eg using 'checkSecurity').----fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath name prefix) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix-                          ++ FilePath.Posix.splitDirectories name-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id---- | Convert a native 'FilePath' to a 'TarPath'.------ The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a--- description of the problem with splitting long 'FilePath's.----toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for-                  -- directories a 'TarPath' must always use a trailing @\/@.-          -> FilePath -> Either String TarPath-toTarPath isDir = splitLongPath-                . addTrailingSep-                . FilePath.Posix.joinPath-                . FilePath.Native.splitDirectories-  where-    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator-                   | otherwise = id---- | Take a sanitized path, split on directory separators and try to pack it--- into the 155 + 100 tar file name format.------ The strategy is this: take the name-directory components in reverse order--- and try to fit as many components into the 100 long name area as possible.--- If all the remaining components fit in the 155 name area then we win.----splitLongPath :: FilePath -> Either String TarPath-splitLongPath path =-  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of-    Left err                 -> Left err-    Right (name, [])         -> Right (TarPath name "")-    Right (name, first:rest) -> case packName prefixMax remainder of-      Left err               -> Left err-      Right (_     , _ : _)  -> Left "File name too long (cannot split)"-      Right (prefix, [])     -> Right (TarPath name prefix)-      where-        -- drop the '/' between the name and prefix:-        remainder = init first : rest--  where-    nameMax, prefixMax :: Int-    nameMax   = 100-    prefixMax = 155--    packName _      []     = Left "File name empty"-    packName maxLen (c:cs)-      | n > maxLen         = Left "File name too long"-      | otherwise          = Right (packName' maxLen n [c] cs)-      where n = length c--    packName' maxLen n ok (c:cs)-      | n' <= maxLen             = packName' maxLen n' (c:ok) cs-                                     where n' = n + length c-    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)---- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and--- 'HardLink' entry types.----newtype LinkTarget = LinkTarget FilePath-  deriving (Eq, Ord)---- | Convert a tar 'LinkTarget' to a native 'FilePath'.----fromLinkTarget :: LinkTarget -> FilePath-fromLinkTarget (LinkTarget path) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id------- * Entries type------- | A tar archive is a sequence of entries.-data Entries = Next Entry Entries-             | Done-             | Fail String--unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries-unfoldrEntries f = unfold-  where-    unfold x = case f x of-      Left err             -> Fail err-      Right Nothing        -> Done-      Right (Just (e, x')) -> Next e (unfold x')--foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a-foldrEntries next done fail' = fold-  where-    fold (Next e es) = next e (fold es)-    fold Done        = done-    fold (Fail err)  = fail' err--foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a-foldlEntries f = fold-  where-    fold a (Next e es) = (fold $! f a e) es-    fold a Done        = Right a-    fold _ (Fail err)  = Left err--mapEntries :: (Entry -> Entry) -> Entries -> Entries-mapEntries f = foldrEntries (Next . f) Done Fail--filterEntries :: (Entry -> Bool) -> Entries -> Entries+filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e filterEntries p =-  foldrEntries-    (\entry rest -> if p entry-                      then Next entry rest-                      else rest)-    Done Fail--checkEntries :: (Entry -> Maybe String) -> Entries -> Entries-checkEntries checkEntry =-  foldrEntries-    (\entry rest -> case checkEntry entry of-                      Nothing  -> Next entry rest-                      Just err -> Fail err)-    Done Fail--entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)-entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty------- * Checking------- | This function checks a sequence of tar entries for file name security--- problems. It checks that:------ * file paths are not absolute------ * file paths do not contain any path components that are \"@..@\"------ * file names are valid------ These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive--- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the--- link target. A failure in any entry terminates the sequence of entries with--- an error.----checkSecurity :: Entries -> Entries-checkSecurity = checkEntries checkEntrySecurity--checkTarbomb :: FilePath -> Entries -> Entries-checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)--checkEntrySecurity :: Entry -> Maybe String-checkEntrySecurity entry = case entryContent entry of-    HardLink     link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    SymbolicLink link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    _                 -> check (entryPath entry)--  where-    check name-      | not (FilePath.Native.isRelative name)-      = Just $ "Absolute file name in tar archive: " ++ show name--      | not (FilePath.Native.isValid name)-      = Just $ "Invalid file name in tar archive: " ++ show name--      | ".." `elem` FilePath.Native.splitDirectories name-      = Just $ "Invalid file name in tar archive: " ++ show name--      | otherwise = Nothing--checkEntryTarbomb :: FilePath -> Entry -> Maybe String-checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing-  where-    -- Ignore some special entries we will not unpack anyway-    nonFilesystemEntry =-      case entryContent entry of-        OtherEntryType 'g' _ _ -> True --PAX global header-        OtherEntryType 'x' _ _ -> True --PAX individual header-        _                      -> False--checkEntryTarbomb expectedTopDir entry =-  case FilePath.Native.splitDirectories (entryPath entry) of-    (topDir:_) | topDir == expectedTopDir -> Nothing-    s -> Just $ "File in tar archive is not in the expected directory. "-             ++ "Expected: " ++ show expectedTopDir-             ++ " but got the following hierarchy: "-             ++ show s-------- * Reading-----read :: ByteString -> Entries-read = unfoldrEntries getEntry--getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))-getEntry bs-  | BS.length header < 512 = Left "truncated tar archive"--  -- Tar files end with at least two blocks of all '0'. Checking this serves-  -- two purposes. It checks the format but also forces the tail of the data-  -- which is necessary to close the file if it came from a lazily read file.-  | BS.head bs == 0 = case BS.splitAt 1024 bs of-      (end, trailing)-        | BS.length end /= 1024        -> Left "short tar trailer"-        | not (BS.all (== 0) end)      -> Left "bad tar trailer"-        | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"-        | otherwise                    -> Right Nothing--  | otherwise  = partial $ do--  case (chksum_, format_) of-    (Ok chksum, _   ) | correctChecksum header chksum -> return ()-    (Ok _,      Ok _) -> fail "tar checksum error"-    _                 -> fail "data is not in tar format"--  -- These fields are partial, have to check them-  format   <- format_;   mode     <- mode_;-  uid      <- uid_;      gid      <- gid_;-  size     <- size_;     mtime    <- mtime_;-  devmajor <- devmajor_; devminor <- devminor_;--  let content = BS.take size (BS.drop 512 bs)-      padding = (512 - size) `mod` 512-      bs'     = BS.drop (512 + size + padding) bs--      entry = Entry {-        entryTarPath     = TarPath name prefix,-        entryContent     = case typecode of-                   '\0' -> NormalFile      content size-                   '0'  -> NormalFile      content size-                   '1'  -> HardLink        (LinkTarget linkname)-                   '2'  -> SymbolicLink    (LinkTarget linkname)-                   '3'  -> CharacterDevice devmajor devminor-                   '4'  -> BlockDevice     devmajor devminor-                   '5'  -> Directory-                   '6'  -> NamedPipe-                   '7'  -> NormalFile      content size-                   _    -> OtherEntryType  typecode content size,-        entryPermissions = mode,-        entryOwnership   = Ownership uname gname uid gid,-        entryTime        = mtime,-        entryFormat      = format-    }--  return (Just (entry, bs'))--  where-   header = BS.take 512 bs--   name       = getString   0 100 header-   mode_      = getOct    100   8 header-   uid_       = getOct    108   8 header-   gid_       = getOct    116   8 header-   size_      = getOct    124  12 header-   mtime_     = getOct    136  12 header-   chksum_    = getOct    148   8 header-   typecode   = getByte   156     header-   linkname   = getString 157 100 header-   magic      = getChars  257   8 header-   uname      = getString 265  32 header-   gname      = getString 297  32 header-   devmajor_  = getOct    329   8 header-   devminor_  = getOct    337   8 header-   prefix     = getString 345 155 header--- trailing   = getBytes  500  12 header--   format_ = case magic of-    "\0\0\0\0\0\0\0\0" -> return V7Format-    "ustar\NUL00"      -> return UstarFormat-    "ustar  \NUL"      -> return GnuFormat-    _                  -> fail "tar entry not in a recognised format"--correctChecksum :: ByteString -> Int -> Bool-correctChecksum header checksum = checksum == checksum'-  where-    -- sum of all 512 bytes in the header block,-    -- treating each byte as an 8-bit unsigned value-    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'-    -- treating the 8 bytes of chksum as blank characters.-    header'   = BS.concat [BS.take 148 header,-                           BS.Char8.replicate 8 ' ',-                           BS.drop 156 header]---- * TAR format primitive input--getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a-getOct off len header-  | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))-  | null octstr          = return 0-  | otherwise            = case readOct octstr of-               [(x,[])] -> return x-               _        -> fail "tar header is malformed (bad numeric encoding)"-  where-    bytes  = getBytes off len header-    octstr = BS.Char8.unpack-           . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')-           . BS.Char8.dropWhile (== ' ')-           $ bytes--    -- Some tar programs switch into a binary format when they try to represent-    -- field values that will not fit in the required width when using the text-    -- octal format. In particular, the UID/GID fields can only hold up to 2^21-    -- while in the binary format can hold up to 2^32. The binary format uses-    -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.-    parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =-      return $! shiftL (fromIntegral byte3) 24-              + shiftL (fromIntegral byte2) 16-              + shiftL (fromIntegral byte1) 8-              + shiftL (fromIntegral byte0) 0-    parseBinInt _ = fail "tar header uses non-standard number encoding"--getBytes :: Int64 -> Int64 -> ByteString -> ByteString-getBytes off len = BS.take len . BS.drop off--getByte :: Int64 -> ByteString -> Char-getByte off bs = BS.Char8.index bs off--getChars :: Int64 -> Int64 -> ByteString -> String-getChars off len = BS.Char8.unpack . getBytes off len--getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0')-                    . getBytes off len--data Partial a = Error String | Ok a-  deriving Functor--partial :: Partial a -> Either String a-partial (Error msg) = Left msg-partial (Ok x)      = Right x--instance Applicative Partial where-    pure          = return-    (<*>)         = ap--instance Monad Partial where-    return        = Ok-    Error m >>= _ = Error m-    Ok    x >>= k = k x-    fail          = Error------- * Writing------- | Create the external representation of a tar archive by serialising a list--- of tar entries.------ * The conversion is done lazily.----write :: [Entry] -> ByteString-write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]---- | Same as 'write', but for 'Entries'.-writeEntries :: Entries -> ByteString-writeEntries entries = BS.concat $ foldrEntries (\e res -> putEntry e : res)-                       [BS.replicate (512*2) 0] error entries--putEntry :: Entry -> ByteString-putEntry entry = case entryContent entry of-  NormalFile       content size -> BS.concat [ header, content, padding size ]-  OtherEntryType _ content size -> BS.concat [ header, content, padding size ]-  _                             -> header-  where-    header       = putHeader entry-    padding size = BS.replicate paddingSize 0-      where paddingSize = fromIntegral (negate size `mod` 512)--putHeader :: Entry -> ByteString-putHeader entry =-     BS.concat [ BS.take 148 block-               , BS.Char8.pack $ putOct 7 checksum-               , BS.Char8.singleton ' '-               , BS.drop 156 block ]-  where-    -- putHeaderNoChkSum returns a String, so we convert it to the final-    -- representation before calculating the checksum.-    block    = BS.Char8.pack . putHeaderNoChkSum $ entry-    checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block--putHeaderNoChkSum :: Entry -> String-putHeaderNoChkSum Entry {-    entryTarPath     = TarPath name prefix,-    entryContent     = content,-    entryPermissions = permissions,-    entryOwnership   = ownership,-    entryTime        = modTime,-    entryFormat      = format-  } =--  concat-    [ putString  100 $ name-    , putOct       8 $ permissions-    , putOct       8 $ ownerId ownership-    , putOct       8 $ groupId ownership-    , putOct      12 $ contentSize-    , putOct      12 $ modTime-    , fill         8 $ ' ' -- dummy checksum-    , putChar8       $ typeCode-    , putString  100 $ linkTarget-    ] ++-  case format of-  V7Format    ->-      fill 255 '\NUL'-  UstarFormat -> concat-    [ putString    8 $ "ustar\NUL00"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putOct       8 $ deviceMajor-    , putOct       8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  GnuFormat -> concat-    [ putString    8 $ "ustar  \NUL"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putGnuDev    8 $ deviceMajor-    , putGnuDev    8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  where-    (typeCode, contentSize, linkTarget,-     deviceMajor, deviceMinor) = case content of-       NormalFile      _ size            -> ('0' , size, [],   0,     0)-       Directory                         -> ('5' , 0,    [],   0,     0)-       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link, 0,     0)-       HardLink        (LinkTarget link) -> ('1' , 0,    link, 0,     0)-       CharacterDevice major minor       -> ('3' , 0,    [],   major, minor)-       BlockDevice     major minor       -> ('4' , 0,    [],   major, minor)-       NamedPipe                         -> ('6' , 0,    [],   0,     0)-       OtherEntryType  code _ size       -> (code, size, [],   0,     0)--    putGnuDev w n = case content of-      CharacterDevice _ _ -> putOct w n-      BlockDevice     _ _ -> putOct w n-      _                   -> replicate w '\NUL'---- * TAR format primitive output--type FieldWidth = Int--putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'----TODO: check integer widths, eg for large file sizes-putOct :: (Show a, Integral a) => FieldWidth -> a -> String-putOct n x =-  let octStr = take (n-1) $ showOct x ""-   in fill (n - length octStr - 1) '0'-   ++ octStr-   ++ putChar8 '\NUL'--putChar8 :: Char -> String-putChar8 c = [c]--fill :: FieldWidth -> Char -> String-fill n c = replicate n c------- * Unpacking-----unpack :: FilePath -> Entries -> IO ()-unpack baseDir entries = unpackEntries [] (checkSecurity entries)-                     >>= emulateLinks--  where-    -- We're relying here on 'checkSecurity' to make sure we're not scribbling-    -- files all over the place.--    unpackEntries _     (Fail err)      = fail err-    unpackEntries links Done            = return links-    unpackEntries links (Next entry es) = case entryContent entry of-      NormalFile file _ -> extractFile entry path file-                        >> unpackEntries links es-      Directory         -> extractDir path-                        >> unpackEntries links es-      HardLink     link -> (unpackEntries $! saveLink path link links) es-      SymbolicLink link -> (unpackEntries $! saveLink path link links) es-      _                 -> unpackEntries links es --ignore other file types-      where-        path = entryPath entry--    extractFile entry path content = do-      -- Note that tar archives do not make sure each directory is created-      -- before files they contain, indeed we may have to create several-      -- levels of directory.-      createDirectoryIfMissing True absDir-      BS.writeFile absPath content-      when (isExecutable (entryPermissions entry))-           (setFileExecutable absPath)-      where-        absDir  = baseDir </> FilePath.Native.takeDirectory path-        absPath = baseDir </> path--    extractDir path = createDirectoryIfMissing True (baseDir </> path)--    saveLink path link links = seq (length path)-                             $ seq (length link')-                             $ (path, link'):links-      where link' = fromLinkTarget link--    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->-      let absPath   = baseDir </> relPath-          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget-       in copyFile absTarget absPath------- * Packing-----pack :: FilePath   -- ^ Base directory-     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir-     -> IO [Entry]-pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir--preparePaths :: FilePath -> [FilePath] -> IO [FilePath]-preparePaths baseDir paths =-  fmap concat $ interleave-    [ do isDir  <- doesDirectoryExist (baseDir </> path)-         if isDir-           then do entries <- getDirectoryContentsRecursive (baseDir </> path)-                   return (FilePath.Native.addTrailingPathSeparator path-                         : map (path </>) entries)-           else return [path]-    | path <- paths ]--packPaths :: FilePath -> [FilePath] -> IO [Entry]-packPaths baseDir paths =-  interleave-    [ do tarpath <- either fail return (toTarPath isDir relpath)-         if isDir then packDirectoryEntry filepath tarpath-                  else packFileEntry      filepath tarpath-    | relpath <- paths-    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath-          filepath = baseDir </> relpath ]--interleave :: [IO a] -> IO [a]-interleave = unsafeInterleaveIO . go-  where-    go []     = return []-    go (x:xs) = do-      x'  <- x-      xs' <- interleave xs-      return (x':xs')--packFileEntry :: FilePath -- ^ Full path to find the file on the local disk-              -> TarPath  -- ^ Path to use for the tar Entry in the archive-              -> IO Entry-packFileEntry filepath tarpath = do-  mtime   <- getModTime filepath-  perms   <- getPermissions filepath-  file    <- openBinaryFile filepath ReadMode-  size    <- hFileSize file-  content <- BS.hGetContents file-  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {-    entryPermissions = if Permissions.executable perms-                         then executableFilePermissions-                         else ordinaryFilePermissions,-    entryTime = mtime-  }--packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk-                   -> TarPath  -- ^ Path to use for the tar Entry in the archive-                   -> IO Entry-packDirectoryEntry filepath tarpath = do-  mtime   <- getModTime filepath-  return (directoryEntry tarpath) {-    entryTime = mtime-  }--getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir0 =-  fmap tail (recurseDirectories dir0 [""])--recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]-recurseDirectories _    []         = return []-recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do-  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)+  Tar.foldEntries+    (\e es -> if p e then Tar.Next e es else es)+    Tar.Done+    Tar.Fail -  files' <- recurseDirectories base (dirs' ++ dirs)-  return (dir : files ++ files')+filterEntriesM :: Monad m => (Tar.Entry -> m Bool)+               -> Tar.Entries e -> m (Tar.Entries e)+filterEntriesM p =+  Tar.foldEntries+    (\entry rest -> do+         keep <- p entry+         xs   <- rest+         if keep+           then return (Tar.Next entry xs)+           else return xs)+    (return Tar.Done)+    (return . Tar.Fail) -  where-    collect files dirs' []              = return (reverse files, reverse dirs')-    collect files dirs' (entry:entries) | ignore entry-                                        = collect files dirs' entries-    collect files dirs' (entry:entries) = do-      let dirEntry  = dir </> entry-          dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry-      isDirectory <- doesDirectoryExist (base </> dirEntry)-      if isDirectory-        then collect files (dirEntry':dirs') entries-        else collect (dirEntry:files) dirs' entries+entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]+entriesToList = Tar.foldEntries (:) [] throw -    ignore ['.']      = True-    ignore ['.', '.'] = True-    ignore _          = False
Distribution/Client/Targets.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Targets@@ -40,8 +42,11 @@    -- * User constraints   UserConstraint(..),+  userConstraintPackageName,   readUserConstraint,-  userToPackageConstraint+  userToPackageConstraint,+  dispFlagAssignment,+  parseFlagAssignment,    ) where @@ -52,14 +57,19 @@ import Distribution.Client.Types          ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types-         ( PackageConstraint(..) )+         ( PackageConstraint(..), ConstraintSource(..)+         , LabeledPackageConstraint(..) )  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 import Distribution.Client.FetchUtils import Distribution.Client.Utils ( tryFindPackageDesc )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )  import Distribution.PackageDescription          ( GenericPackageDescription, FlagName(..), FlagAssignment )@@ -72,7 +82,7 @@          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, fromUTF8, lowercase )+         ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM )  import Data.List          ( find, nub )@@ -92,6 +102,8 @@ 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          ( (<>), (<+>) )@@ -103,6 +115,8 @@          ( doesFileExist, doesDirectoryExist ) import Network.URI          ( URI(..), URIAuth(..), parseAbsoluteURI )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary)  -- ------------------------------------------------------------ -- * User targets@@ -179,19 +193,24 @@      -- | A fully specified source package.      --    | SpecificSourcePackage pkg-  deriving Show+  deriving (Eq, Show, Generic) +instance Binary pkg => Binary (PackageSpecifier pkg)+ pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _)       = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg  pkgSpecifierConstraints :: Package pkg-                        => PackageSpecifier pkg -> [PackageConstraint]-pkgSpecifierConstraints (NamedPackage _ constraints) = constraints+                        => PackageSpecifier pkg -> [LabeledPackageConstraint]+pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints+  where+    toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-  [PackageConstraintVersion (packageName pkg)-                            (thisVersion (packageVersion pkg))]-+    [LabeledPackageConstraint pc ConstraintSourceUserTarget]+  where+    pc = PackageConstraintVersion (packageName pkg)+         (thisVersion (packageVersion pkg))  -- ------------------------------------------------------------ -- * Parsing and checking user targets@@ -264,7 +283,7 @@             uriScheme    = scheme,             uriAuthority = Just URIAuth { uriRegName = host }           }-          | scheme /= "http:" ->+          | scheme /= "http:" && scheme /= "https:" ->             Just (Left (UserTargetUnexpectedUriScheme targetstr))            | null host ->@@ -331,7 +350,7 @@               $ unlines                   [ "URL target not supported '" ++ name ++ "'."                   | name <- target ]-             ++ "Only 'http://' URLs are supported."+             ++ "Only 'http://' and 'https://' URLs are supported."      case [ target | UserTargetUnrecognisedUri target <- problems ] of       []     -> return ()@@ -351,16 +370,17 @@ -- resolveUserTargets :: Package pkg                    => Verbosity+                   -> RepoContext                    -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]                    -> IO [PackageSpecifier SourcePackage]-resolveUserTargets verbosity worldFile available userTargets = do+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) . concat+                  =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat                   =<< mapM (expandUserTarget worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must@@ -447,13 +467,14 @@ -- | Fetch any remote targets so that they can be read. -- fetchPackageTarget :: Verbosity+                   -> RepoContext                    -> PackageTarget (PackageLocation ())                    -> IO (PackageTarget (PackageLocation FilePath))-fetchPackageTarget verbosity target = case target of+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 (fmap (const Nothing) location)+      location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location)       return (PackageTargetLocation location')  @@ -516,7 +537,7 @@     extractTarballPackageCabalFile tarballFile tarballOriginalLoc =           either (die . formatErr) return         . check-        . Tar.entriesIndex+        . accumEntryMap         . Tar.filterEntries isCabalFile         . Tar.read         . GZipUtils.maybeDecompress@@ -524,7 +545,11 @@       where         formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg -        check (Left e)  = Left e+        accumEntryMap = Tar.foldlEntries+                          (\m e -> Map.insert (Tar.entryTarPath e) e m)+                          Map.empty++        check (Left e)  = Left (show e)         check (Right m) = case Map.elems m of             []     -> Left noCabalFile             [file] -> case Tar.entryContent file of@@ -542,7 +567,7 @@      parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription     parsePackageDescription' content =-      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ pkg -> Just pkg         _             -> Nothing @@ -553,7 +578,7 @@  data PackageTargetProblem    = PackageNameUnknown   PackageName               UserTarget-   | PackageNameAmbigious PackageName [PackageName] UserTarget+   | PackageNameAmbiguous PackageName [PackageName] UserTarget   deriving Show  @@ -581,7 +606,7 @@         case disambiguatePackageName packageNameEnv pkgname of           None                 -> Left  (PackageNameUnknown                                           pkgname userTarget)-          Ambiguous   pkgnames -> Left  (PackageNameAmbigious+          Ambiguous   pkgnames -> Left  (PackageNameAmbiguous                                           pkgname pkgnames userTarget)           Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')             where@@ -607,11 +632,11 @@                   ++ "You may need to run 'cabal update' to get the latest "                   ++ "list of available packages." -    case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of+    case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of       []          -> return ()       ambiguities -> die $ unlines                              [    "The package name '" ++ display name-                               ++ "' is ambigious. It could be: "+                               ++ "' is ambiguous. It could be: "                                ++ intercalate ", " (map display matches)                              | (name, matches) <- ambiguities ] @@ -630,17 +655,17 @@ -- * Disambiguating package names -- ------------------------------------------------------------ -data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]+data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]  -- | Given a package name and a list of matching names, figure out which one it -- might be referring to. If there is an exact case-sensitive match then that's -- ok. If it matches just one package case-insensitively then that's also ok. -- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambigious.+-- that case it is ambiguous. -- disambiguatePackageName :: PackageNameEnv                         -> PackageName-                        -> MaybeAmbigious PackageName+                        -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name =     case nub (pkgNameLookup name) of       []      -> None@@ -654,10 +679,13 @@  instance Monoid PackageNameEnv where   mempty = PackageNameEnv (const [])-  mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =+  mappend = (Semi.<>)++instance Semi.Semigroup PackageNameEnv where+  PackageNameEnv lookupA <> PackageNameEnv lookupB =     PackageNameEnv (\name -> lookupA name ++ lookupB name) -indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup   where     pkgNameLookup (PackageName name) =@@ -683,9 +711,18 @@    | UserConstraintSource    PackageName    | UserConstraintFlags     PackageName FlagAssignment    | UserConstraintStanzas   PackageName [OptionalStanza]-  deriving (Show,Eq)+  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+ userToPackageConstraint :: UserConstraint -> PackageConstraint -- At the moment, the types happen to be directly equivalent userToPackageConstraint uc = case uc of@@ -713,7 +750,6 @@          "expected a package name followed by a constraint, which is "       ++ "either a version range, 'installed', 'source' or flags" ---FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where   disp (UserConstraintVersion   pkgname verrange) = disp pkgname                                                     <+> disp verrange@@ -723,12 +759,6 @@                                                     <+> Disp.text "source"   disp (UserConstraintFlags     pkgname flags)    = disp pkgname                                                     <+> dispFlagAssignment flags-    where-      dispFlagAssignment = Disp.hsep . map dispFlagValue-      dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f-      dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f-      dispFlagName (FlagName f) = Disp.text f-   disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname                                                     <+> dispStanzas stanzas     where@@ -738,37 +768,51 @@    parse = parse >>= parseConstraint     where-      spaces = Parse.satisfy isSpace >> Parse.skipSpaces-       parseConstraint pkgname =             ((parse >>= return . UserConstraintVersion pkgname)-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "installed"                 return (UserConstraintInstalled pkgname))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "source"                 return (UserConstraintSource pkgname))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "test"                 return (UserConstraintStanzas pkgname [TestStanzas]))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "bench"                 return (UserConstraintStanzas pkgname [BenchStanzas])))-        <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))+        <++ (do skipSpaces1+                flags <- parseFlagAssignment+                return (UserConstraintFlags pkgname flags)) -      parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)-      parseFlagValue =-            (do Parse.optional (Parse.char '+')-                f <- parseFlagName-                return (f, True))-        +++ (do _ <- Parse.char '-'-                f <- parseFlagName-                return (f, False))-      parseFlagName = liftM FlagName ident+--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 -      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 ()+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+
Distribution/Client/Types.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Types@@ -15,11 +19,11 @@ module Distribution.Client.Types where  import Distribution.Package-         ( PackageName, PackageId, Package(..), PackageFixedDeps(..)-         , mkPackageKey, PackageKey, InstalledPackageId(..)-         , PackageInstalled(..) )+         ( PackageName, PackageId, Package(..)+         , UnitId(..), mkUnitId+         , HasUnitId(..), PackageInstalled(..) ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, packageKey )+         ( InstalledPackageInfo ) import Distribution.PackageDescription          ( Benchmark(..), GenericPackageDescription(..), FlagAssignment          , TestSuite(..) )@@ -27,18 +31,22 @@          ( mapTreeData ) import Distribution.Client.PackageIndex          ( PackageIndex )+import Distribution.Client.ComponentDeps+         ( ComponentDeps )+import qualified Distribution.Client.ComponentDeps as CD import Distribution.Version          ( VersionRange )-import Distribution.Simple.Compiler-         ( Compiler, packageKeySupported ) import Distribution.Text (display)  import Data.Map (Map)-import Network.URI (URI)+import Network.URI (URI(..), URIAuth(..), nullURI) import Data.ByteString.Lazy (ByteString) import Control.Exception          ( SomeException )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..)) + newtype Username = Username { unUsername :: String } newtype Password = Password { unPassword :: String } @@ -48,49 +56,55 @@   packageIndex       :: PackageIndex SourcePackage,   packagePreferences :: Map PackageName VersionRange }+  deriving (Eq, Generic) +instance Binary SourcePackageDb+ -- ------------------------------------------------------------ -- * Various kinds of information about packages -- ------------------------------------------------------------ --- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.--- What is new in 1.8 is that installed packages and dependencies between--- installed packages are now identified by an opaque InstalledPackageId--- rather than a source PackageId.+-- | Within Cabal the library we no longer have a @InstalledPackageId@ type.+-- That's because it deals with the compilers' notion of a registered library,+-- and those really are libraries not packages. Those are now named units. ----- We should use simply an 'InstalledPackageInfo' here but to ease the--- transition we are temporarily using this variant where we pretend that--- installed packages still specify their deps in terms of PackageIds.+-- The package management layer does however deal with installed packages, as+-- whole packages not just as libraries. So we do still need a type for+-- installed package ids. At the moment however we track instaled packages via+-- their primary library, which is a unit id. In future this may change+-- slightly and we may distinguish these two types and have an explicit+-- conversion when we register units with the compiler. ----- Crucially this means that 'InstalledPackage' can be an instance of--- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance--- of that class. This means we can make 'PackageIndex'es of InstalledPackage--- where as the InstalledPackageInfo now has its own monomorphic index type.+type InstalledPackageId = UnitId++installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId+installedPackageId = installedUnitId++-- | Subclass of packages that have specific versioned dependencies. ---data InstalledPackage = InstalledPackage-       InstalledPackageInfo-       [PackageId]+-- 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 Package InstalledPackage where-  packageId (InstalledPackage pkg _) = packageId pkg-instance PackageFixedDeps InstalledPackage where-  depends (InstalledPackage _ deps) = deps-instance PackageInstalled InstalledPackage where-  installedPackageId (InstalledPackage pkg _) = installedPackageId pkg-  installedDepends (InstalledPackage pkg _) = installedDepends pkg+instance PackageFixedDeps InstalledPackageInfo where+  depends = CD.fromInstalled . installedDepends   -- | In order to reuse the implementation of PackageIndex which relies on--- 'InstalledPackageId', we need to be able to synthesize these IDs prior+-- 'UnitId', we need to be able to synthesize these IDs prior -- to installation.  Eventually, we'll move to a representation of--- 'InstalledPackageId' which can be properly computed before compilation+-- '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.-fakeInstalledPackageId :: PackageId -> InstalledPackageId-fakeInstalledPackageId = InstalledPackageId . (".fake."++) . display+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@@ -101,55 +115,76 @@        SourcePackage       -- package info, including repo        FlagAssignment      -- complete flag assignment for the package        [OptionalStanza]    -- list of enabled optional stanzas for the package-       [PackageId]         -- set of exact dependencies. These must be-                           -- consistent with the 'buildDepends' in the-                           -- 'PackageDescription' that you'd get by applying-                           -- the flag assignment and optional stanzas.-  deriving Show+       (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++-- | 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+-- 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+  }+  deriving (Eq, Generic)++instance Binary ConfiguredId++instance Show ConfiguredId where+  show = show . confSrcId++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) = deps+  depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps -instance PackageInstalled ConfiguredPackage where-  installedPackageId = fakeInstalledPackageId . packageId-  installedDepends = map fakeInstalledPackageId . depends+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 ReadyPackage = ReadyPackage-       SourcePackage           -- see 'ConfiguredPackage'.-       FlagAssignment          ---       [OptionalStanza]        ---       [InstalledPackageInfo]  -- Installed dependencies.-  deriving Show+data GenericReadyPackage srcpkg ipkg+   = ReadyPackage+       srcpkg                  -- see 'ConfiguredPackage'.+       (ComponentDeps [ipkg])  -- Installed dependencies.+  deriving (Eq, Show, Generic) -instance Package ReadyPackage where-  packageId (ReadyPackage pkg _ _ _) = packageId pkg+type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo -instance PackageFixedDeps ReadyPackage where-  depends (ReadyPackage _ _ _ deps) = map packageId deps+instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where+  packageId (ReadyPackage srcpkg _deps) = packageId srcpkg -instance PackageInstalled ReadyPackage where-  installedPackageId = fakeInstalledPackageId . packageId-  installedDepends (ReadyPackage _ _ _ ipis) = map installedPackageId ipis+instance (Package srcpkg, HasUnitId ipkg) =>+         PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where+  depends (ReadyPackage _ deps) = fmap (map installedUnitId) deps --- | Extracts a package key from ReadyPackage, a common operation needed--- to calculate build paths.-readyPackageKey :: Compiler -> ReadyPackage -> PackageKey-readyPackageKey comp (ReadyPackage pkg _ _ deps) =-    mkPackageKey (packageKeySupported comp) (packageId pkg)-                 (map packageKey deps) []+instance HasUnitId srcpkg =>+         HasUnitId (GenericReadyPackage srcpkg ipkg) where+  installedUnitId (ReadyPackage pkg _) = installedUnitId pkg +instance (Binary srcpkg, Binary ipkg) => Binary (GenericReadyPackage srcpkg ipkg) --- | Sometimes we need to convert a 'ReadyPackage' back to a--- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*--- Ready or Configured.-readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage-readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =-  ConfiguredPackage srcpkg flags stanzas (map packageId deps)  -- | A package description along with the location of the package sources. --@@ -159,8 +194,10 @@     packageSource        :: PackageLocation (Maybe FilePath),     packageDescrOverride :: PackageDescriptionOverride   }-  deriving Show+  deriving (Eq, Show, Generic) +instance Binary SourcePackage+ -- | We sometimes need to override the .cabal file in the tarball with -- the newer one from the package index. type PackageDescriptionOverride = Maybe ByteString@@ -170,8 +207,10 @@ data OptionalStanza     = TestStanzas     | BenchStanzas-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Enum, Bounded, Show, Generic) +instance Binary OptionalStanza+ enableStanzas     :: [OptionalStanza]     -> GenericPackageDescription@@ -210,23 +249,94 @@ --TODO: --  * add support for darcs and other SCM style remote repos with a local cache --  | ScmPackage-  deriving (Show, Functor)+  deriving (Show, Functor, Eq, Ord, Generic) -data LocalRepo = LocalRepo-  deriving (Show,Eq)+instance Binary local => Binary (PackageLocation local) -data RemoteRepo = RemoteRepo {-    remoteRepoName :: String,-    remoteRepoURI  :: URI-  }-  deriving (Show,Eq,Ord)+-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier+-- versions do not, so we use manual Binary instances here+instance Binary URI where+  put (URI a b c d e) = do put a; put b; put c; put d; put e+  get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get+           return (URI a b c d e) -data Repo = Repo {-    repoKind     :: Either RemoteRepo LocalRepo,-    repoLocalDir :: FilePath-  }-  deriving (Show,Eq)+instance Binary URIAuth where+  put (URIAuth a b c) = do put a; put b; put c+  get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) +data RemoteRepo =+    RemoteRepo {+      remoteRepoName     :: String,+      remoteRepoURI      :: URI,++      -- | Enable secure access?+      --+      -- 'Nothing' here represents "whatever the default is"; this is important+      -- to allow for a smooth transition from opt-in to opt-out security+      -- (once we switch to opt-out, all access to the central Hackage+      -- repository should be secure by default)+      remoteRepoSecure :: Maybe Bool,++      -- | Root key IDs (for bootstrapping)+      remoteRepoRootKeys :: [String],++      -- | Threshold for verification during bootstrapping+      remoteRepoKeyThreshold :: Int,++      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a+      -- special case we may know a repo supports both and want to try HTTPS+      -- if we can, but still allow falling back to HTTP.+      --+      -- This field is not currently stored in the config file, but is filled+      -- in automagically for known repos.+      remoteRepoShouldTryHttps :: Bool+    }++  deriving (Show, Eq, Ord, Generic)++instance Binary RemoteRepo++-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.+emptyRemoteRepo :: String -> RemoteRepo+emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False++-- | Different kinds of repositories+--+-- NOTE: It is important that this type remains serializable.+data Repo =+    -- | Local repositories+    RepoLocal {+        repoLocalDir :: FilePath+      }++    -- | Standard (unsecured) remote repositores+  | RepoRemote {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }++    -- | Secure repositories+    --+    -- Although this contains the same fields as 'RepoRemote', we use a separate+    -- constructor to avoid confusing the two.+    --+    -- Not all access to a secure repo goes through the hackage-security+    -- library currently; code paths that do not still make use of the+    -- 'repoRemote' and 'repoLocalDir' fields directly.+  | RepoSecure {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }+  deriving (Show, Eq, Ord, Generic)++instance Binary Repo++-- | Check if this is a remote repo+maybeRepoRemote :: Repo -> Maybe RemoteRepo+maybeRepoRemote (RepoLocal    _localDir) = Nothing+maybeRepoRemote (RepoRemote r _localDir) = Just r+maybeRepoRemote (RepoSecure r _localDir) = Just r+ -- ------------------------------------------------------------ -- * Build results -- ------------------------------------------------------------@@ -240,8 +350,22 @@                   | BuildFailed     SomeException                   | TestsFailed     SomeException                   | InstallFailed   SomeException+  deriving (Show, Generic) data BuildSuccess = BuildOk         DocsResult TestsResult                                     (Maybe InstalledPackageInfo)+  deriving (Show, Generic)  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+  deriving (Show, Generic) data TestsResult = TestsNotTried | TestsOk+  deriving (Show, Generic)++instance Binary BuildFailure+instance Binary BuildSuccess+instance Binary DocsResult+instance Binary TestsResult++--FIXME: this is a total cheat+instance Binary SomeException where+  put _ = return ()+  get = fail "cannot serialise exceptions"
Distribution/Client/Update.hs view
@@ -10,46 +10,79 @@ -- -- -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} module Distribution.Client.Update     ( update     ) where  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..) )+         ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils          ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import Distribution.Client.IndexUtils-         ( updateRepoIndexCache )+         ( updateRepoIndexCache, Index(..) )+import Distribution.Client.JobControl+         ( newParallelJobControl, spawnJob, collectJob )+import Distribution.Client.Setup+         ( RepoContext(..) )+import Distribution.Verbosity+         ( Verbosity )  import Distribution.Simple.Utils          ( writeFileAtomic, warn, notice )-import Distribution.Verbosity-         ( Verbosity )  import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath (dropExtension)+import Data.Maybe (catMaybes)+import Data.Time (getCurrentTime) +import qualified Hackage.Security.Client as Sec+ -- | 'update' downloads the package list from all known servers-update :: Verbosity -> [Repo] -> IO ()-update verbosity [] =+update :: Verbosity -> RepoContext -> IO ()+update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."-update verbosity repos = do-  mapM_ (updateRepo verbosity) repos+update verbosity repoCtxt = do+  jobCtrl <- newParallelJobControl+  let repos       = repoContextRepos repoCtxt+      remoteRepos = catMaybes (map maybeRepoRemote repos)+  case remoteRepos of+    [] -> return ()+    [remoteRepo] ->+        notice verbosity $ "Downloading the latest package list from "+                        ++ remoteRepoName remoteRepo+    _ -> notice verbosity . unlines+            $ "Downloading the latest package lists from: "+            : map (("- " ++) . remoteRepoName) remoteRepos+  mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos+  mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: Verbosity -> Repo -> IO ()-updateRepo verbosity repo = case repoKind repo of-  Right LocalRepo -> return ()-  Left remoteRepo -> do-    notice verbosity $ "Downloading the latest package list from "-                    ++ remoteRepoName remoteRepo-    downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo)-    case downloadResult of-      FileAlreadyInCache -> return ()-      FileDownloaded indexPath -> do-        writeFileAtomic (dropExtension indexPath) . maybeDecompress-                                                =<< BS.readFile indexPath-        updateRepoIndexCache verbosity repo+updateRepo :: Verbosity -> RepoContext -> Repo -> IO ()+updateRepo verbosity repoCtxt repo = do+  transport <- repoContextGetTransport repoCtxt+  case repo of+    RepoLocal{..} -> return ()+    RepoRemote{..} -> do+      downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir+      case downloadResult of+        FileAlreadyInCache -> return ()+        FileDownloaded indexPath -> do+          writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                  =<< BS.readFile indexPath+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+      ce <- if repoContextIgnoreExpiry repoCtxt+              then Just `fmap` getCurrentTime+              else return Nothing+      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce+      -- Update cabal's internal index as well so that it's not out of sync+      -- (If all access to the cache goes through hackage-security this can go)+      case updated of+        Sec.NoUpdates  ->+          return ()+        Sec.HasUpdates ->+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
Distribution/Client/Upload.hs view
@@ -1,15 +1,13 @@--- This is a quick hack for uploading packages to Hackage.--- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload--module Distribution.Client.Upload (check, upload, report) where--import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)-import           Data.ByteString.Lazy.Char8 (ByteString)+module Distribution.Client.Upload (check, upload, uploadDoc, report) where -import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))-import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse)+import Distribution.Client.Types ( Username(..), Password(..)+                                 , RemoteRepo(..), maybeRepoRemote )+import Distribution.Client.HttpUtils+         ( HttpTransport(..), remoteRepoTryUpgradeToHttps )+import Distribution.Client.Setup+         ( RepoContext(..) ) -import Distribution.Simple.Utils (debug, notice, warn, info)+import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config@@ -17,47 +15,89 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.Browser-         ( request )-import Network.HTTP-         ( Header(..), HeaderName(..), findHeader-         , Request(..), RequestMethod(..), Response(..) ) import Network.URI (URI(uriPath), parseURI)+import Network.HTTP (Header(..), HeaderName(..)) -import Data.Char        (intToDigit)-import Numeric          (showHex) import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho)+import System.Exit      (exitFailure) import Control.Exception (bracket)-import System.Random    (randomRIO) import System.FilePath  ((</>), takeExtension, takeFileName)-import qualified System.FilePath.Posix as FilePath.Posix (combine)+import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory import Control.Monad (forM_, when)-+import Data.Maybe (catMaybes) ---FIXME: how do we find this path for an arbitrary hackage server?--- is it always at some fixed location relative to the server root?-legacyUploadURI :: URI-Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"+type Auth = Maybe (String, String)  checkURI :: URI-Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"+Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/"+                           ++ "hackage-scripts/check-pkg" +upload :: Verbosity -> RepoContext+       -> Maybe Username -> Maybe Password -> [FilePath]+       -> IO ()+upload verbosity repoCtxt mUsername mPassword 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)+    let targetRepoURI = remoteRepoURI targetRepo+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> "upload"+        }+    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 -upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()-upload verbosity repos mUsername mPassword paths = do-          let uploadURI = if isOldHackageURI targetRepoURI-                          then legacyUploadURI-                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}-          Username username <- maybe promptUsername return mUsername-          Password password <- maybe promptPassword return mPassword-          let auth = Just (username, password)-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Uploading " ++ path ++ "... "-            handlePackage verbosity uploadURI auth path-  where-    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given+uploadDoc :: Verbosity -> RepoContext+          -> Maybe Username -> Maybe Password -> FilePath+          -> IO ()+uploadDoc verbosity repoCtxt mUsername mPassword 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)+    let targetRepoURI = remoteRepoURI targetRepo+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> "package/" ++ pkgid ++ "/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"+    Username username <- maybe promptUsername return mUsername+    Password password <- maybe promptPassword return mPassword +    let auth = Just (username,password)+        headers =+          [ Header HdrContentType "application/x-tar"+          , Header HdrContentEncoding "gzip"+          ]+    notice verbosity $ "Uploading documentation " ++ path ++ "... "+    resp <- putHttpFile transport verbosity uploadURI path auth headers+    case resp of+      (200,_)     ->+        notice verbosity "Ok"+      (code,err)  -> do+        notice verbosity $ "Error uploading documentation "+                        ++ path ++ ": "+                        ++ "http code " ++ show code ++ "\n"+                        ++ err+        exitFailure+ promptUsername :: IO Username promptUsername = do   putStr "Hackage username: "@@ -75,99 +115,49 @@   putStrLn ""   return passwd -report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()-report verbosity repos mUsername mPassword = do-      Username username <- maybe promptUsername return mUsername-      Password password <- maybe promptPassword return mPassword-      let auth = Just (username, password)-      forM_ repos $ \repo -> case repoKind repo of-        Left remoteRepo-            -> do dotCabal <- defaultCabalDir-                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo-                  -- We don't want to bomb out just because we haven't built any packages from this repo yet-                  srcExists <- doesDirectoryExist srcDir-                  when srcExists $ do-                    contents <- getDirectoryContents srcDir-                    forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->-                        do inp <- readFile (srcDir </> logFile)-                           let (reportStr, buildLog) = read inp :: (String,String)-                           case BuildReport.parse reportStr of-                             Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME-                             Right report' ->-                                 do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')-                                    cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]-                                    return ()-        Right{} -> return ()+report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()+report verbosity repoCtxt mUsername mPassword = do+  Username username <- maybe promptUsername return mUsername+  Password password <- maybe promptPassword return mPassword+  let auth        = (username, password)+      repos       = repoContextRepos repoCtxt+      remoteRepos = catMaybes (map maybeRepoRemote repos)+  forM_ remoteRepos $ \remoteRepo ->+      do dotCabal <- defaultCabalDir+         let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+         -- We don't want to bomb out just because we haven't built any packages+         -- from this repo yet.+         srcExists <- doesDirectoryExist srcDir+         when srcExists $ do+           contents <- getDirectoryContents srcDir+           forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->+             do inp <- readFile (srcDir </> logFile)+                let (reportStr, buildLog) = read inp :: (String,String)+                case BuildReport.parse reportStr of+                  Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME+                  Right report' ->+                    do info verbosity $ "Uploading report for "+                         ++ display (BuildReport.package report')+                       BuildReport.uploadReports verbosity repoCtxt auth+                         (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                       return () -check :: Verbosity -> [FilePath] -> IO ()-check verbosity paths = do-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Checking " ++ path ++ "... "-            handlePackage verbosity checkURI Nothing path+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 :: Verbosity -> URI -> Maybe (String, String)+handlePackage :: HttpTransport -> Verbosity -> URI -> Auth               -> FilePath -> IO ()-handlePackage verbosity uri auth path =-  do req <- mkRequest uri path-     debug verbosity $ "\n" ++ show req-     (_,resp) <- cabalBrowse verbosity auth $ request req-     debug verbosity $ show resp-     case rspCode resp of-       (2,0,0) -> do notice verbosity "Ok"-       (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "-                                     ++ map intToDigit [x,y,z] ++ " "-                                     ++ rspReason resp-                     case findHeader HdrContentType resp of-                       Just contenttype-                         | takeWhile (/= ';') contenttype == "text/plain"-                         -> notice verbosity $ B.unpack $ rspBody resp-                       _ -> debug verbosity $ B.unpack $ rspBody resp--mkRequest :: URI -> FilePath -> IO (Request ByteString)-mkRequest uri path = -    do pkg <- readBinaryFile path-       boundary <- genBoundary-       let body = printMultiPart (B.pack boundary) (mkFormData path pkg)-       return $ Request {-                         rqURI = uri,-                         rqMethod = POST,-                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (B.length body)),-                                      Header HdrAccept ("text/plain")],-                         rqBody = body-                        }--readBinaryFile :: FilePath -> IO ByteString-readBinaryFile = B.readFile--genBoundary :: IO String-genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer-                 return $ showHex i ""--mkFormData :: FilePath -> ByteString -> [BodyPart]-mkFormData path pkg =-  -- yes, web browsers are that stupid (re quoting)-  [BodyPart [Header hdrContentDisposition $-             "form-data; name=package; filename=\""++takeFileName path++"\"",-             Header HdrContentType "application/x-gzip"]-   pkg]--hdrContentDisposition :: HeaderName-hdrContentDisposition = HdrCustom "Content-disposition"---- * Multipart, partly stolen from the cgi package.--data BodyPart = BodyPart [Header] ByteString--printMultiPart :: ByteString -> [BodyPart] -> ByteString-printMultiPart boundary xs =-    B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf]--printBodyPart :: ByteString -> BodyPart -> ByteString-printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c]--crlf :: ByteString-crlf = B.pack "\r\n"--dd :: ByteString-dd = B.pack "--"+handlePackage transport verbosity uri auth path =+  do resp <- postHttpFile transport verbosity uri path auth+     case resp of+       (200,_)     ->+          notice verbosity "Ok"+       (code,err)  -> do+          notice verbosity $ "Error uploading " ++ path ++ ": "+                          ++ "http code " ++ show code ++ "\n"+                          ++ err+          exitFailure
Distribution/Client/Utils.hs view
@@ -2,9 +2,14 @@  module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy-                                 , inDir, determineNumJobs, numberOfProcessors+                                 , readMaybe+                                 , inDir, logDirChange+                                 , determineNumJobs, numberOfProcessors                                  , removeExistingFile-                                 , makeAbsoluteToCwd, filePathToByteString+                                 , withTempFileName+                                 , makeAbsoluteToCwd+                                 , makeRelativeToCwd, makeRelativeToDir+                                 , filePathToByteString                                  , byteStringToFilePath, tryCanonicalizePath                                  , canonicalizePathNoThrow                                  , moreRecentFile, existsAndIsMoreRecentThan@@ -18,26 +23,33 @@ import Distribution.Simple.Setup       ( Flag(..) ) 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 Data.List          ( isPrefixOf, sortBy, groupBy ) import Data.Word          ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception-         ( finally )+         ( finally, bracket ) import System.Directory          ( canonicalizePath, doesFileExist, getCurrentDirectory          , removeFile, setCurrentDirectory ) import System.FilePath-         ( (</>), isAbsolute )+         ( (</>), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO-         ( Handle+         ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0)          , hGetEncoding, hSetEncoding #endif@@ -51,7 +63,7 @@          ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) #endif -#if defined(mingw32_HOST_OS)+#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import Prelude hiding (ioError) import Control.Monad (liftM2, unless) import System.Directory (doesDirectoryExist)@@ -87,6 +99,14 @@     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 ()@@ -95,6 +115,19 @@   when exists $     removeFile path +-- | A variant of 'withTempFile' that only gives us the file name, and while+-- it will clean up the file afterwards, it's lenient if the file is+-- moved\/deleted.+--+withTempFileName :: FilePath+                 -> String+                 -> (FilePath -> IO a) -> IO a+withTempFileName tmpDir template action =+  Exception.bracket+    (openTempFile tmpDir template)+    (\(name, _) -> removeExistingFile name)+    (\(name, h) -> hClose h >> action name)+ -- | Executes the action in the specified directory. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m@@ -103,6 +136,14 @@   setCurrentDirectory d   m `Exception.finally` setCurrentDirectory old +-- | Log directory change in 'make' compatible syntax+logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a+logDirChange _ Nothing m = m+logDirChange l (Just d) m = do+  l $ "cabal: Entering directory '" ++ d ++ "'\n"+  m `Exception.finally`+    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")+ foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt  -- The number of processors is not going to change during the duration of the@@ -125,6 +166,30 @@                        | otherwise       = do cwd <- getCurrentDirectory                                               return $! cwd </> path +-- | Given a path (relative or absolute), make it relative to the current+-- directory, including using @../..@ if necessary.+makeRelativeToCwd :: FilePath -> IO FilePath+makeRelativeToCwd path =+    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory++-- | Given a path (relative or absolute), make it relative to the given+-- directory, including using @../..@ if necessary.+makeRelativeToDir :: FilePath -> FilePath -> IO FilePath+makeRelativeToDir path dir =+    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir++-- | Given a canonical absolute path and canonical absolute dir, make the path+-- relative to the directory, including using @../..@ if necessary. Returns+-- the original absolute path if it is not on the same drive as the given dir.+makeRelativeCanonical :: FilePath -> FilePath -> FilePath+makeRelativeCanonical path dir+  | takeDrive path /= takeDrive dir = path+  | otherwise                       = go (splitPath path) (splitPath dir)+  where+    go (p:ps) (d:ds) | p == d = go ps ds+    go    []     []           = "./"+    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)+ -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is -- encoded as a little-endian 'Word32'. filePathToByteString :: FilePath -> BS.ByteString@@ -160,13 +225,12 @@         b2 = fromIntegral $ BS.index bs (i + 2)         b3 = fromIntegral $ BS.index bs (i + 3) --- | Workaround for the inconsistent behaviour of 'canonicalizePath'. It throws--- an error if the path refers to a non-existent file on *nix, but not on--- Windows.+-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always+-- throws an error if the path refers to a non-existent file. tryCanonicalizePath :: FilePath -> IO FilePath tryCanonicalizePath path = do   ret <- canonicalizePath path-#if defined(mingw32_HOST_OS)+#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)   exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)   unless exists $     ioError $ mkIOError doesNotExistErrorType "canonicalizePath"
+ Distribution/Client/Utils/Json.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Minimal JSON / RFC 7159 support+--+-- The API is heavily inspired by @aeson@'s API but puts emphasis on+-- simplicity rather than performance. The 'ToJSON' instances are+-- intended to have an encoding compatible with @aeson@'s encoding.+--+module Distribution.Client.Utils.Json+    ( Value(..)+    , Object, object, Pair, (.=)+    , encodeToString+    , encodeToBuilder+    , ToJSON(toJSON)+    )+    where++import Data.Char+import Data.Int+import Data.String+import Data.Word+import Data.List+import Data.Monoid++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array  [Value]+           | String  String+           | Number !Double+           | Bool   !Bool+           | Null+           deriving (Eq, Read, Show)++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++infixr 8 .=++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON v => String -> v -> Pair+k .= v  = (k, toJSON v)++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+  fromString = String+++-- | A type that can be converted to JSON.+class ToJSON a where+  -- | Convert a Haskell value to a JSON-friendly intermediate type.+  toJSON :: a -> Value++instance ToJSON () where+  toJSON () = Array []++instance ToJSON Value where+  toJSON = id++instance ToJSON Bool where+  toJSON = Bool++instance ToJSON a => ToJSON [a] where+  toJSON = Array . map toJSON++instance ToJSON a => ToJSON (Maybe a) where+  toJSON Nothing  = Null+  toJSON (Just a) = toJSON a++instance (ToJSON a,ToJSON b) => ToJSON (a,b) where+  toJSON (a,b) = Array [toJSON a, toJSON b]++instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]++instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]++instance ToJSON Float where+  toJSON = Number . realToFrac++instance ToJSON Double where+  toJSON = Number++instance ToJSON Int    where  toJSON = Number . realToFrac+instance ToJSON Int8   where  toJSON = Number . realToFrac+instance ToJSON Int16  where  toJSON = Number . realToFrac+instance ToJSON Int32  where  toJSON = Number . realToFrac++instance ToJSON Word   where  toJSON = Number . realToFrac+instance ToJSON Word8  where  toJSON = Number . realToFrac+instance ToJSON Word16 where  toJSON = Number . realToFrac+instance ToJSON Word32 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Int64  where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Word64 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Integer where toJSON = Number . fromInteger++------------------------------------------------------------------------------+-- 'BB.Builder'-based encoding++-- | Serialise value as JSON/UTF8-encoded 'Builder'+encodeToBuilder :: ToJSON a => a -> Builder+encodeToBuilder = encodeValueBB . toJSON++encodeValueBB :: Value -> Builder+encodeValueBB jv = case jv of+  Bool True  -> "true"+  Bool False -> "false"+  Null       -> "null"+  Number n+    | isNaN n || isInfinite n   -> encodeValueBB Null+    | Just i <- doubleToInt64 n -> BB.int64Dec i+    | otherwise                 -> BB.doubleDec n+  Array a  -> encodeArrayBB a+  String s -> encodeStringBB s+  Object o -> encodeObjectBB o++encodeArrayBB :: [Value] -> Builder+encodeArrayBB [] = "[]"+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB++encodeObjectBB :: Object -> Builder+encodeObjectBB [] = "{}"+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x++encodeStringBB :: String -> Builder+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'+  where+    go = BB.stringUtf8 . escapeString++------------------------------------------------------------------------------+-- 'String'-based encoding++-- | Serialise value as JSON-encoded Unicode 'String'+encodeToString :: ToJSON a => a -> String+encodeToString jv = encodeValue (toJSON jv) []++encodeValue :: Value -> ShowS+encodeValue jv = case jv of+  Bool b   -> showString (if b then "true" else "false")+  Null     -> showString "null"+  Number n+    | isNaN n || isInfinite n    -> encodeValue Null+    | Just i <- doubleToInt64 n -> shows i+    | otherwise                 -> shows n+  Array a -> encodeArray a+  String s -> encodeString s+  Object o -> encodeObject o++encodeArray :: [Value] -> ShowS+encodeArray [] = showString "[]"+encodeArray jvs = ('[':) . go jvs . (']':)+  where+    go []     = id+    go [x]    = encodeValue x+    go (x:xs) = encodeValue x . (',':) . go xs++encodeObject :: Object -> ShowS+encodeObject [] = showString "{}"+encodeObject jvs = ('{':) . go jvs . ('}':)+  where+    go []          = id+    go [(l,x)]     = encodeString l . (':':) . encodeValue x+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs++encodeString :: String -> ShowS+encodeString str = ('"':) . showString (escapeString str) . ('"':)++------------------------------------------------------------------------------+-- helpers++-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not+-- representable loss-free as integral 'Int64' value.+doubleToInt64 :: Double -> Maybe Int64+doubleToInt64 x+  | fromInteger x' == x+  , x' <= toInteger (maxBound :: Int64)+  , x' >= toInteger (minBound :: Int64)+    = Just (fromIntegral x')+  | otherwise = Nothing+  where+    x' = round x++-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"+escapeString :: String -> String+escapeString s+  | not (any needsEscape s) = s+  | otherwise               = escape s+  where+    escape [] = []+    escape (x:xs) = case x of+      '\\' -> '\\':'\\':escape xs+      '"'  -> '\\':'"':escape xs+      '\b' -> '\\':'b':escape xs+      '\f' -> '\\':'f':escape xs+      '\n' -> '\\':'n':escape xs+      '\r' -> '\\':'r':escape xs+      '\t' -> '\\':'t':escape xs+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs+        | otherwise    -> c : escape xs++    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
+ Distribution/Client/Utils/LabeledGraph.hs view
@@ -0,0 +1,116 @@+-- | 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
Main.hs view
@@ -16,15 +16,16 @@ module Main (main) where  import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand, globalRepos+         ( GlobalFlags(..), globalCommand, withRepoContext          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand          , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)          , buildCommand, replCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand+         , installCommand, upgradeCommand, uninstallCommand          , FetchFlags(..), fetchCommand          , FreezeFlags(..), freezeCommand+         , genBoundsCommand          , GetFlags(..), getCommand, unpackCommand          , checkCommand          , formatCommand@@ -37,10 +38,12 @@          , 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@@ -58,21 +61,26 @@          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config          ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff-         , userConfigUpdate )+         , 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 Distribution.Client.Upload as Upload   (upload, check, report)+import qualified Distribution.Client.Upload as Upload import Distribution.Client.Run                (run, splitRunArgs) import Distribution.Client.SrcDist            (sdist) import Distribution.Client.Get                (get)@@ -86,6 +94,7 @@                                                ,getSandboxConfigFilePath                                               ,loadConfigOrSandboxConfig+                                              ,findSavedDistPref                                               ,initPackageDBIfNeeded                                               ,maybeWithSandboxDirOnSearchPath                                               ,maybeWithSandboxPackageInfo@@ -94,15 +103,20 @@                                               ,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)@@ -110,18 +124,21 @@ #endif                                               ,existsAndIsMoreRecentThan) +import Distribution.Package (packageId) import Distribution.PackageDescription-         ( Executable(..), benchmarkName, benchmarkBuildInfo, testName-         , testBuildInfo, buildable )+         ( 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-         , commandsRun, commandAddAction, hiddenCommand )+         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)+         , CommandType(..), commandsRun, commandAddAction, hiddenCommand+         , commandFromSpec) import Distribution.Simple.Compiler          ( Compiler(..) ) import Distribution.Simple.Configure@@ -130,7 +147,10 @@          , getPersistBuildConfig, tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Program (defaultProgramConfiguration-                                   ,configureAllKnownPrograms)+                                   ,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@@ -144,8 +164,9 @@ import qualified Paths_cabal_install (version)  import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure)-import System.FilePath          (splitExtension, takeExtension)+import System.Exit              (exitFailure, exitSuccess)+import System.FilePath          ( dropExtension, splitExtension+                                , takeExtension, (</>), (<.>)) import System.IO                ( BufferMode(LineBuffering), hSetBuffering #ifdef mingw32_HOST_OS                                 , stderr@@ -153,9 +174,10 @@                                 , stdout ) import System.Directory         (doesFileExist, getCurrentDirectory) import Data.List                (intercalate)-import Data.Maybe               (mapMaybe)+import Data.Maybe               (listToMaybe) #if !MIN_VERSION_base(4,8,0) import Data.Monoid              (Monoid(..))+import Control.Applicative      (pure, (<$>)) #endif import Control.Monad            (when, unless) @@ -213,74 +235,96 @@     printNumericVersion = putStrLn $ display Paths_cabal_install.version     printVersion        = putStrLn $ "cabal-install version "                                   ++ display Paths_cabal_install.version-                                  ++ "\nusing version "+                                  ++ "\ncompiled using version "                                   ++ display cabalVersion                                   ++ " of the Cabal library " -    commands =-      [installCommand         `commandAddAction` installAction-      ,updateCommand          `commandAddAction` updateAction-      ,listCommand            `commandAddAction` listAction-      ,infoCommand            `commandAddAction` infoAction-      ,fetchCommand           `commandAddAction` fetchAction-      ,freezeCommand          `commandAddAction` freezeAction-      ,getCommand             `commandAddAction` getAction-      ,hiddenCommand $-       unpackCommand          `commandAddAction` unpackAction-      ,checkCommand           `commandAddAction` checkAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,uploadCommand          `commandAddAction` uploadAction-      ,reportCommand          `commandAddAction` reportAction-      ,runCommand             `commandAddAction` runAction-      ,initCommand            `commandAddAction` initAction-      ,configureExCommand     `commandAddAction` configureAction-      ,buildCommand           `commandAddAction` buildAction-      ,replCommand            `commandAddAction` replAction-      ,sandboxCommand         `commandAddAction` sandboxAction-      ,haddockCommand         `commandAddAction` haddockAction-      ,execCommand            `commandAddAction` execAction-      ,userConfigCommand      `commandAddAction` userConfigAction-      ,cleanCommand           `commandAddAction` cleanAction-      ,wrapperAction copyCommand-                     copyVerbosity     copyDistPref-      ,wrapperAction hscolourCommand-                     hscolourVerbosity hscolourDistPref-      ,wrapperAction registerCommand-                     regVerbosity      regDistPref-      ,testCommand            `commandAddAction` testAction-      ,benchmarkCommand       `commandAddAction` benchmarkAction-      ,hiddenCommand $-       formatCommand          `commandAddAction` formatAction-      ,hiddenCommand $-       upgradeCommand         `commandAddAction` upgradeAction-      ,hiddenCommand $-       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction+    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 (GlobalFlags -> IO ())+              -> Command Action wrapperAction command verbosityFlag distPrefFlag =   commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do+    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do     let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-        setupScriptOptions = defaultSetupScriptOptions {-          useDistPref = fromFlagOrDefault-                          (useDistPref defaultSetupScriptOptions)-                          (distPrefFlag flags)-        }+    (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+    distPref <- findSavedDistPref config (distPrefFlag flags)+    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }     setupWrapper verbosity setupScriptOptions Nothing                  command (const flags) extraArgs  configureAction :: (ConfigFlags, ConfigExFlags)-                -> [String] -> GlobalFlags -> IO ()+                -> [String] -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) -  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                          globalFlags (configUserInstall 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@@ -305,24 +349,24 @@       (compilerId comp) platform    maybeWithSandboxDirOnSearchPath useSandbox $+   withRepoContext verbosity globalFlags' $ \repoContext ->     configure verbosity               (configPackageDB' configFlags'')-              (globalRepos globalFlags')+              repoContext               comp platform conf configFlags'' configExFlags' extraArgs -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                    (buildDistPref buildFlags)-      verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+  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) <- reconfigure verbosity distPref-                          mempty [] globalFlags noAddSource-                          (buildNumJobs buildFlags) (const Nothing)+  (useSandbox, config, distPref) <- reconfigure verbosity+                                    (buildDistPref buildFlags)+                                    mempty [] globalFlags noAddSource+                                    (buildNumJobs buildFlags) (const Nothing)    maybeWithSandboxDirOnSearchPath useSandbox $     build verbosity config distPref buildFlags extraArgs@@ -365,7 +409,7 @@     numJobsCmdLineFlag = buildNumJobs buildFlags  -replAction :: (ReplFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action replAction (replFlags, buildExFlags) extraArgs globalFlags = do   cwd     <- getCurrentDirectory   pkgDesc <- findPackageDesc cwd@@ -376,13 +420,17 @@     -- There is a .cabal file in the current directory: start a REPL and load     -- the project's modules.     onPkgDesc = do-      let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                        (replDistPref replFlags)-          noAddSource = case replReload replFlags of+      let noAddSource = case replReload replFlags of             Flag True -> SkipAddSourceDepsCheck             _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck                          (buildOnly buildExFlags)-          progConf     = defaultProgramConfiguration+      -- 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@@ -391,11 +439,6 @@             { replVerbosity = toFlag verbosity             , replDistPref  = toFlag distPref             }-      -- Calls 'configureAction' to do the real work, so nothing special has to-      -- be done to support sandboxes.-      (useSandbox, _config) <- reconfigure verbosity distPref-                               mempty [] globalFlags noAddSource NoFlag-                               (const Nothing)        maybeWithSandboxDirOnSearchPath useSandbox $         setupWrapper verbosity setupOptions Nothing@@ -405,10 +448,14 @@     -- using the sandbox package DB).     onNoPkgDesc = do       (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-                               mempty       let configFlags = savedConfigureFlags config-      (comp, _platform, programDb) <- configCompilerAux' configFlags-      startInterpreter verbosity programDb comp (configPackageDB' configFlags)+      (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:@@ -441,7 +488,7 @@ -- these required settings will be checked first upon determining that -- a previous configuration exists. reconfigure :: Verbosity    -- ^ Verbosity setting-            -> FilePath     -- ^ \"dist\" prefix+            -> 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@@ -467,13 +514,16 @@                             -- prefix setting is always required, it is checked                             -- automatically; this function need not check                             -- for it.-            -> IO (UseSandbox, SavedConfig)-reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags+            -> 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-  case eLbi of-    Left err  -> onNoBuildConfig err-    Right lbi -> onBuildConfig lbi+  config' <- case eLbi of+    Left err  -> onNoBuildConfig (useSandbox, config) distPref err+    Right lbi -> onBuildConfig (useSandbox, config) distPref lbi+  return (useSandbox, config', distPref)    where @@ -481,30 +531,44 @@     --     -- If we're in a sandbox: add-source deps don't have to be reinstalled     -- (since we don't know the compiler & platform).-    onNoBuildConfig :: ConfigStateFileError -> IO (UseSandbox, SavedConfig)-    onNoBuildConfig err = do+    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-      loadConfigOrSandboxConfig verbosity globalFlags mempty+      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 :: LBI.LocalBuildInfo -> IO (UseSandbox, SavedConfig)-    onBuildConfig lbi = do+    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@@ -522,14 +586,18 @@       when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $         info verbosity "Skipping add-source deps check..." -      (useSandbox, config, depsReinstalled) <-+      let (_, config') = updateInstallDirs+                         (configUserInstall flags)+                         (useSandbox, config)++      depsReinstalled <-         case skipAddSourceDepsCheck' of-        DontSkipAddSourceDepsCheck     ->-          maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags-        SkipAddSourceDepsCheck -> do-          (useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                                  globalFlags (configUserInstall flags)-          return (useSandbox, config, NoDepsReinstalled)+          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@@@ -539,36 +607,37 @@        -- Determine whether we need to reconfigure and which message to show to       -- the user if that is the case.-      mMsg <- determineMessageToShow lbi configFlags depsReinstalled-                                     isSandboxConfigNewer+      mMsg <- determineMessageToShow distPref lbi configFlags+                                     depsReinstalled isSandboxConfigNewer                                      isUserPackageEnvironmentFileNewer       case mMsg of          -- No message for the user indicates that reconfiguration         -- is not required.-        Nothing -> return (useSandbox, config)+        Nothing -> return config'          -- Show the message and reconfigure.         Just msg -> do           notice verbosity msg           configureAction (flags, defaultConfigExFlags)             extraArgs globalFlags-          return (useSandbox, config)+          return config'      -- Determine what message, if any, to display to the user if reconfiguration     -- is required.-    determineMessageToShow :: LBI.LocalBuildInfo -> ConfigFlags+    determineMessageToShow :: FilePath -> LBI.LocalBuildInfo -> ConfigFlags                             -> WereDepsReinstalled -> Bool -> Bool                             -> IO (Maybe String)-    determineMessageToShow _   _           _               True  _     =+    determineMessageToShow _ _   _           _               True  _     =       -- The sandbox was created after the package was already configured.       return $! Just $! sandboxConfigNewerMessage -    determineMessageToShow _   _           _               False True  =+    determineMessageToShow _ _   _           _               False True  =       -- The user package environment file was modified.       return $! Just $! userPackageEnvironmentFileModifiedMessage -    determineMessageToShow lbi configFlags depsReinstalled False False = do+    determineMessageToShow distPref lbi configFlags depsReinstalled+                           False False = do       let savedDistPref = fromFlagOrDefault                           (useDistPref defaultSetupScriptOptions)                           (configDistPref configFlags)@@ -597,11 +666,6 @@                             then Just $! outdatedMessage pdFile                             else Nothing -    defaultFlags = mappend addConfigFlags distVerbFlags-    distVerbFlags = mempty-        { configVerbosity = toFlag verbosity-        , configDistPref  = toFlag distPref-        }     reconfiguringMostRecent = " Re-configuring with most recently used options."     configureManually       = " If this fails, please run configure manually."     sandboxConfigNewerMessage =@@ -627,18 +691,21 @@         ++ configureManually  installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, _, installFlags, _) _ _globalFlags-  | fromFlagOrDefault False (installOnly installFlags)-  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    in setupWrapper verbosity defaultSetupScriptOptions Nothing-         installCommand (const mempty) []+              -> [String] -> Action+installAction (configFlags, _, installFlags, _) _ globalFlags+  | fromFlagOrDefault False (installOnly installFlags) = do+      let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+      (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+      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) <- loadConfigOrSandboxConfig verbosity-                          globalFlags (configUserInstall 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@@ -654,28 +721,32 @@   let sandboxDistPref = case useSandbox of         NoSandbox             -> NoFlag         UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-      configFlags'    = maybeForceTests installFlags' $-                        savedConfigureFlags   config `mappend` configFlags+  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+                        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.+  -- 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') {-            configDistPref = sandboxDistPref-            }+    NoSandbox               -> configAbsolutePaths $ configFlags'+    (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform+                                                     configFlags'    whenUsingSandbox useSandbox $ \sandboxDir -> do     initPackageDBIfNeeded verbosity configFlags'' comp conf'@@ -684,7 +755,7 @@     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile       (compilerId comp) platform -  -- FIXME: Passing 'SandboxPackageInfo' to install unconditionally here means+  -- 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@@ -692,9 +763,10 @@   maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'                               comp platform conf useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $+    withRepoContext verbosity globalFlags' $ \repoContext ->       install verbosity               (configPackageDB' configFlags'')-              (globalRepos globalFlags')+              repoContext               comp platform conf'               useSandbox mSandboxPkgInfo               globalFlags' configFlags'' configExFlags'@@ -709,54 +781,72 @@         else configFlags'  testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags-              -> IO ()+           -> IO () testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                       (testDistPref testFlags)-      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-      buildFlags'    = buildFlags { buildVerbosity = testVerbosity testFlags-                                  , buildDistPref  = testDistPref testFlags }       addConfigFlags = mempty { configTests = toFlag True }+      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."-      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck-                       (buildOnly buildExFlags)    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []-                          globalFlags noAddSource-                          (buildNumJobs buildFlags') checkFlags+  (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-  lbi <- getPersistBuildConfig distPref-  let pkgDescr = LBI.localPkgDescr lbi-      nameTestsOnly =-        LBI.foldComponent-          (const Nothing)-          (const Nothing)-          (\t ->-            if buildable (testBuildInfo t)-              then Just (testName t)-            else Nothing)-          (const Nothing)-      tests = mapMaybe nameTestsOnly $ LBI.pkgComponents pkgDescr-      extraArgs'-        | null extraArgs = tests-        | otherwise = extraArgs+  -- 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 -  if null tests-    then notice verbosity "Package has no buildable test suites."-    else do-      maybeWithSandboxDirOnSearchPath useSandbox $-        build verbosity config distPref buildFlags' extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags' extraArgs' -      maybeWithSandboxDirOnSearchPath useSandbox $-        setupWrapper verbosity setupOptions Nothing-          Cabal.testCommand (const testFlags) 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 ()@@ -764,13 +854,9 @@                 extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal                        (benchmarkVerbosity benchmarkFlags)-      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                       (benchmarkDistPref benchmarkFlags)-      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }-      buildFlags'    = buildFlags-        { buildVerbosity = benchmarkVerbosity benchmarkFlags-        , buildDistPref  = benchmarkDistPref  benchmarkFlags }       addConfigFlags = mempty { configBenchmarks = toFlag True }+      buildFlags'    = buildFlags+                       { buildVerbosity = benchmarkVerbosity benchmarkFlags }       checkFlags flags         | fromFlagOrDefault False (configBenchmarks flags) = Nothing         | otherwise = Just "Re-configuring with benchmarks enabled."@@ -779,68 +865,69 @@    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []-                          globalFlags noAddSource (buildNumJobs buildFlags')-                          checkFlags+  (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-  lbi <- getPersistBuildConfig distPref-  let pkgDescr = LBI.localPkgDescr lbi-      nameBenchsOnly =-        LBI.foldComponent-          (const Nothing)-          (const Nothing)-          (const Nothing)-          (\b ->-            if buildable (benchmarkBuildInfo b)-              then Just (benchmarkName b)-            else Nothing)-      benchs = mapMaybe nameBenchsOnly $ LBI.pkgComponents pkgDescr-      extraArgs'-        | null extraArgs = benchs-        | otherwise = extraArgs+  -- 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 -  if null benchs-    then notice verbosity "Package has no buildable benchmarks."-    else do-      maybeWithSandboxDirOnSearchPath useSandbox $-        build verbosity config distPref buildFlags' extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags' extraArgs' -      maybeWithSandboxDirOnSearchPath useSandbox $-        setupWrapper verbosity setupOptions Nothing-          Cabal.benchmarkCommand (const benchmarkFlags) extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    setupWrapper verbosity setupOptions Nothing+    Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' -haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()+haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do   let verbosity = fromFlag (haddockVerbosity haddockFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config, distPref) <-+    reconfigure verbosity (haddockDistPref haddockFlags)+                mempty [] globalFlags DontSkipAddSourceDepsCheck+                NoFlag (const Nothing)   let haddockFlags' = defaultHaddockFlags      `mappend`-                      savedHaddockFlags config `mappend` haddockFlags-      setupScriptOptions = defaultSetupScriptOptions {-        useDistPref = fromFlagOrDefault-                      (useDistPref defaultSetupScriptOptions)-                      (haddockDistPref haddockFlags')-        }+                      savedHaddockFlags config `mappend`+                      haddockFlags { haddockDistPref = toFlag distPref }+      setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }   setupWrapper verbosity setupScriptOptions Nothing     haddockCommand (const haddockFlags') extraArgs+  when (fromFlagOrDefault False $ haddockForHackage haddockFlags) $ 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] -> GlobalFlags -> IO ()-cleanAction cleanFlags extraArgs _globalFlags =+cleanAction :: CleanFlags -> [String] -> Action+cleanAction cleanFlags extraArgs globalFlags = do+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  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+               cleanCommand (const cleanFlags') extraArgs   where     verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)-    setupScriptOptions = defaultSetupScriptOptions {-      useDistPref = fromFlagOrDefault-                    (useDistPref defaultSetupScriptOptions)-                    (cleanDistPref cleanFlags),-      useWin32CleanHack = True-      } -listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags' = savedConfigureFlags config       configFlags  = configFlags' {         configPackageDBs = configPackageDBs configFlags'@@ -848,19 +935,21 @@         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags-  List.list verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.list verbosity        (configPackageDB' configFlags)-       (globalRepos globalFlags')+       repoContext        comp        conf        listFlags        extraArgs -infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()+infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags' = savedConfigureFlags config       configFlags  = configFlags' {         configPackageDBs = configPackageDBs configFlags'@@ -868,26 +957,29 @@         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAuxEx configFlags-  List.info verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.info verbosity        (configPackageDB' configFlags)-       (globalRepos globalFlags')+       repoContext        comp        conf        globalFlags'        infoFlags        targets -updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+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 NoFlag+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  update verbosity (globalRepos globalFlags')+  withRepoContext verbosity globalFlags' $ \repoContext ->+    update verbosity repoContext  upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> GlobalFlags -> IO ()+              -> [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'. "@@ -901,24 +993,25 @@  ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "  ++ "packages (e.g. by using appropriate --constraint= flags)." -fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()+fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do   let verbosity = fromFlag (fetchVerbosity fetchFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  config <- loadConfig verbosity (globalConfigFile globalFlags)   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags-  fetch verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    fetch verbosity         (configPackageDB' configFlags)-        (globalRepos globalFlags')+        repoContext         comp platform conf globalFlags' fetchFlags         targets -freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do   let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags@@ -926,34 +1019,77 @@   maybeWithSandboxPackageInfo verbosity configFlags globalFlags'                               comp platform conf useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $+    withRepoContext verbosity globalFlags' $ \repoContext ->       freeze verbosity             (configPackageDB' configFlags)-            (globalRepos globalFlags')+            repoContext             comp platform conf             mSandboxPkgInfo             globalFlags' freezeFlags -uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()+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-  let verbosity = fromFlag (uploadVerbosity uploadFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  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-  if fromFlag (uploadCheck uploadFlags')-    then Upload.check  verbosity tarfiles-    else upload verbosity-                (globalRepos globalFlags')-                (flagToMaybe $ uploadUsername uploadFlags')-                (flagToMaybe $ uploadPassword uploadFlags')-                tarfiles-  where+  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-      | null tarfiles-      = die "the 'upload' command expects one or more .tar.gz packages."       | not (null otherFiles)-      = die $ "the 'upload' command expects only .tar.gz packages: "+      = die $ "the 'upload' command expects only .tar.gz archives: "            ++ intercalate ", " otherFiles       | otherwise = sequence_                       [ do exists <- doesFileExist tarfile@@ -964,15 +1100,23 @@             isTarGzFile file = case splitExtension file of               (file', ".gz") -> takeExtension file' == ".tar"               _              -> False+    generateDocTarball config = do+      notice verbosity+        "No documentation tarball specified. Building 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] -> GlobalFlags -> IO ()+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] -> GlobalFlags -> IO ()+formatAction :: Flag Verbosity -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do   let verbosity = fromFlag verbosityFlag   path <- case extraArgs of@@ -983,42 +1127,58 @@   -- Uses 'writeFileAtomic' under the hood.   writeGenericPackageDescription path pkgDesc -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()-sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do+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-  sdist sdistFlags sdistExFlags+  let verbosity = fromFlag (sDistVerbosity sdistFlags)+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (sDistDistPref sdistFlags)+  let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }+  sdist sdistFlags' sdistExFlags -reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()+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) mempty+  config <- loadConfig verbosity (globalConfigFile globalFlags)   let globalFlags' = savedGlobalFlags config `mappend` globalFlags       reportFlags' = savedReportFlags config `mappend` reportFlags -  Upload.report verbosity (globalRepos globalFlags')+  withRepoContext verbosity globalFlags' $ \repoContext ->+   Upload.report verbosity repoContext     (flagToMaybe $ reportUsername reportFlags')     (flagToMaybe $ reportPassword reportFlags') -runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action runAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-      distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                    (buildDistPref buildFlags)-      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck                     (buildOnly buildExFlags)    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref mempty []-                          globalFlags noAddSource (buildNumJobs buildFlags)-                          (const Nothing)+  (useSandbox, config, distPref) <-+    reconfigure verbosity (buildDistPref buildFlags) mempty []+                globalFlags noAddSource (buildNumJobs buildFlags)+                (const Nothing)    lbi <- getPersistBuildConfig distPref-  (exe, exeArgs) <- splitRunArgs lbi extraArgs+  (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $     build verbosity config distPref buildFlags ["exe:" ++ exeName exe]@@ -1026,35 +1186,43 @@   maybeWithSandboxDirOnSearchPath useSandbox $     run verbosity lbi exe exeArgs -getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do   let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  get verbosity-    (globalRepos (savedGlobalFlags config))+  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->+   get verbosity+    repoContext     globalFlags'     getFlags     targets -unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+unpackAction :: GetFlags -> [String] -> Action unpackAction getFlags extraArgs globalFlags = do   getAction getFlags extraArgs globalFlags -initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()-initAction initFlags _extraArgs globalFlags = do+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 mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags  = savedConfigureFlags config+  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags-  initCabal verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    initCabal verbosity             (configPackageDB' configFlags)+            repoContext             comp             conf             initFlags -sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()+sandboxAction :: SandboxFlags -> [String] -> Action sandboxAction sandboxFlags extraArgs globalFlags = do   let verbosity = fromFlag (sandboxVerbosity sandboxFlags)   case extraArgs of@@ -1067,8 +1235,8 @@         sandboxAddSource verbosity extra sandboxFlags globalFlags     ("delete-source":extra) -> do         when (noExtraArgs extra) $-          die "The 'sandbox delete-source' command expects \-              \at least one argument"+          die ("The 'sandbox delete-source' command expects " +++              "at least one argument")         sandboxDeleteSource verbosity extra sandboxFlags globalFlags     ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags @@ -1089,31 +1257,60 @@   where     noExtraArgs = (<1) . length -execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()+execAction :: ExecFlags -> [String] -> Action execAction execFlags extraArgs globalFlags = do   let verbosity = fromFlag (execVerbosity execFlags)   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-                           mempty   let configFlags = savedConfigureFlags config-  (comp, platform, conf) <- configCompilerAux' configFlags+  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags   exec verbosity useSandbox comp platform conf extraArgs -userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()+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 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] -> GlobalFlags-                          -> IO ()+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+  pname <- getProgName+  let cabalCmd = if takeExtension pname == ".exe"+                 then dropExtension pname+                 else pname+  putStrLn $ manpage cabalCmd commands
Setup.hs view
@@ -1,2 +1,53 @@-import Distribution.Simple-main = defaultMain+import Distribution.PackageDescription ( PackageDescription )+import Distribution.Simple ( defaultMainWithHooks+                           , simpleUserHooks+                           , postBuild+                           , postCopy+                           , postInst+                           )+import Distribution.Simple.InstallDirs ( mandir+                                       , CopyDest (NoCopyDest)+                                       )+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)+                                          , absoluteInstallDirs+                                          )+import Distribution.Simple.Utils ( copyFiles+                                 , notice )+import Distribution.Simple.Setup ( buildVerbosity+                                 , copyDest+                                 , copyVerbosity+                                 , fromFlag+                                 , installVerbosity+                                 )+import Distribution.Verbosity ( Verbosity )++import System.IO ( openFile+                 , IOMode (WriteMode)+                 )+import System.Process ( runProcess )+import System.FilePath ( (</>) )+++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks+  { postBuild = \ _ flags _ lbi ->+      buildManpage lbi (fromFlag $ buildVerbosity flags)+  , postCopy = \ _ flags pkg lbi ->+      installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags)+  , postInst = \ _ flags pkg lbi ->+      installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest+  }++buildManpage :: LocalBuildInfo -> Verbosity -> IO ()+buildManpage lbi verbosity = do+  let cabal = buildDir lbi </> "cabal/cabal"+      manpage = buildDir lbi </> "cabal/cabal.1"+  manpageHandle <- openFile manpage WriteMode+  notice verbosity ("Generating manual page " ++ manpage ++ " ...")+  _ <- runProcess cabal ["manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing+  return ()++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")]
bash-completion/cabal view
@@ -45,22 +45,35 @@         case "$word" in           sandbox)             # Get list of "cabal sandbox" subcommands from its help message.-            #-            # Following command short-circuits if it reaches flags section.-            # This is to prevent any problems that might arise from unfortunate-            # word combinations in flag descriptions. Usage section is parsed-            # using simple regexp and "sandbox" subcommand is printed for each-            # successful substitution.             "$1" help sandbox |-            sed -rn '/Flags/q;s/^.* cabal sandbox  *([^ ]*).*/\1/;t p;b;: p;p'+            sed -n '1,/^Subcommands:$/d;/^Flags for sandbox:$/,$d;/^ /d;s/^\(.*\):/\1/p'             break  # Terminate for loop.             ;;         esac     done } +__cabal_has_doubledash ()+{+    local c=1+    # Ignore the last word, because it is replaced anyways.+    # This allows expansion for flags on "cabal foo --",+    # but does not try to complete after "cabal foo -- ".+    local n=$((${#COMP_WORDS[@]} - 1))+    while [ $c -lt $n ]; do+        if [ "--" = "${COMP_WORDS[c]}" ]; then+            return 0+        fi+        ((c++))+    done+    return 1+}+ _cabal() {+    # no completion past cabal arguments.+    __cabal_has_doubledash && return+     # get the word currently being completed     local cur     cur=${COMP_WORDS[$COMP_CWORD]}
bootstrap.sh view
@@ -1,4 +1,4 @@-#!/usr/bin/env sh+#!/bin/sh  # A script to bootstrap cabal-install. @@ -51,43 +51,42 @@ SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" -# Try to respect $TMPDIR but override if needed - see #1710.-[ -"$TMPDIR"- = -""- ] || echo "$TMPDIR" | grep -q ld &&+# Try to respect $TMPDIR.+[ -"$TMPDIR"- = -""- ] &&   export TMPDIR=/tmp/cabal-$(echo $(od -XN4 -An /dev/random)) && mkdir $TMPDIR -# Check for a C compiler.-[ ! -x "$CC" ] && for ccc in gcc clang cc icc; do-  ${ccc} --version > /dev/null 2>&1 && CC=$ccc &&-  echo "Using $CC for C compiler. If this is not what you want, set CC." >&2 &&+# 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 &&+  echo "Using $c for C compiler. If this is not what you want, set CC." >&2 &&   break done  # None found.-[ ! -x `which "$CC"` ] &&-  die "C compiler not found (or could not be run).-       If a C compiler is installed make sure it is on your PATH,-       or set the CC variable."+[ -"$CC"- = -""- ] && die 'C compiler not found (or could not be run).+  If a C compiler is installed make sure it is on your PATH, or set $CC.' -# Check the C compiler/linker work.+# Find the correct linker/linker-wrapper. LINK="$(for link in collect2 ld; do-  echo 'main;' | ${CC} -v -x c - -o /dev/null -\#\#\# 2>&1 | grep -qw $link &&-  echo 'main;' | ${CC} -v -x c - -o /dev/null -\#\#\# 2>&1 | grep -w  $link |-  sed -e "s|\(.*$link\).*|\1|" -e 's/ //g' -e 's|"||' && break-done)"+          [ $($CC -print-prog-name=$link) = $link ] && continue ||+          $CC -print-prog-name=$link+        done)" -# They don't.-[ -z "$LINK" ] &&-  die "C compiler and linker could not compile a simple test program.-       Please check your toolchain."+# Fall back to "ld"... might work.+[ -$LINK- = -""- ] && LINK=ld -## Warn that were's overriding $LD if set (if you want).+# And finally, see if we can compile and link something.+  echo 'int main(){}' | $CC -xc - -o /dev/null ||+    die "C compiler and linker could not compile a simple test program.+    Please check your toolchain." -[ -x "$LD" ] && [ "$LD" != "$LINK" ] &&+# Warn that were's overriding $LD if set (if you want).+[ -"$LD"- != -""- ] && [ -"$LD"- != -"$LINK"- ] &&   echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2   echo "Using $LINK instead." >&2  # Set LD, overriding environment if necessary.-LD=$LINK+export LD=$LINK  # Check we're in the right directory, etc. grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 ||@@ -180,36 +179,52 @@ # The version regex says what existing installed versions are ok. PARSEC_VER="3.1.9";    PARSEC_VER_REGEXP="[3]\.[01]\."                        # >= 3.0 && < 3.2-DEEPSEQ_VER="1.4.1.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."+DEEPSEQ_VER="1.4.2.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."                        # >= 1.1 && < 2-BINARY_VER="0.8.0.1";  BINARY_VER_REGEXP="[0]\.[78]\."+BINARY_VER="0.8.3.0";  BINARY_VER_REGEXP="[0]\.[78]\."                        # >= 0.7 && < 0.9-TEXT_VER="1.2.2.0";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"+TEXT_VER="1.2.2.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"                        # >= 0.2 && < 1.3 NETWORK_VER="2.6.2.1"; NETWORK_VER_REGEXP="2\.[0-6]\."                        # >= 2.0 && < 2.7-NETWORK_URI_VER="2.6.0.3"; NETWORK_URI_VER_REGEXP="2\.6\."+NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\."                        # >= 2.6 && < 2.7-CABAL_VER="1.22.8.0";  CABAL_VER_REGEXP="1\.22"-                       # >= 1.22 && < 1.23-TRANS_VER="0.5.1.0";   TRANS_VER_REGEXP="0\.[45]\."+CABAL_VER="1.24.0.0";  CABAL_VER_REGEXP="1\.24\.[0-9]"+                       # >= 1.24 && < 1.25+TRANS_VER="0.5.2.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.2";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"+HTTP_VER="4000.3.3";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"                        # >= 4000.2.5 < 4000.4-ZLIB_VER="0.6.1.1";    ZLIB_VER_REGEXP="0\.((5\.([3-9]|1[0-9]))|6\.?)"-                       # >= 0.5.3 && < 0.7-TIME_VER="1.6"         TIME_VER_REGEXP="1\.[123456]\.?"+ZLIB_VER="0.6.1.1";    ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"+                       # >= 0.5.3 && <= 0.7+TIME_VER="1.6"         TIME_VER_REGEXP="1\.[1-6]\.?"                        # >= 1.1 && < 1.7 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\."+                       # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?"                        # >=1.0.0.0 && <1.2 OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?"                        # >=1.0.0.0 && <1.1+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\."+                       # >=1.0+CRYPTOHASH_SHA256_VER="0.11.7.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"+                       # 0.11.*+ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"+                       # 0.0.*+HACKAGE_SECURITY_VER="0.5.1.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.[1-9]"+                       # >= 0.5.1 && < 0.6+TAR_VER="0.5.0.1";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.1)\.?"+                       # >= 0.5.0.1  && < 0.6+HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\."+                       # 1.*  HACKAGE_URL="https://hackage.haskell.org/package" @@ -256,24 +271,32 @@   PKG=$1   VER=$2 -  URL=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz+  URL_PKG=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz+  URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal   if which ${CURL} > /dev/null   then     # TODO: switch back to resuming curl command once     #       https://github.com/haskell/hackage-server/issues/111 is resolved-    #${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."-    ${CURL} -L --fail -O ${URL} || die "Failed to download ${PKG}."+    #${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL_PKG} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL_PKGDESC} \+        || die "Failed to download '${PKG}.cabal'."   elif which ${WGET} > /dev/null   then-    ${WGET} -c ${URL} || die "Failed to download ${PKG}."+    ${WGET} -c ${URL_PKG} || die "Failed to download ${PKG}."+    ${WGET} -c ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."   elif which ${FETCH} > /dev/null     then-      ${FETCH} ${URL} || die "Failed to download ${PKG}."+      ${FETCH} ${URL_PKG} || die "Failed to download ${PKG}."+      ${FETCH} ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."   else     die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."   fi   [ -f "${PKG}-${VER}.tar.gz" ] ||-     die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+     die "Downloading ${URL_PKG} did not create ${PKG}-${VER}.tar.gz"+  [ -f "${PKG}.cabal" ] ||+     die "Downloading ${URL_PKGDESC} did not create ${PKG}.cabal"+  mv "${PKG}.cabal" "${PKG}.cabal.hackage" }  unpack_pkg () {@@ -283,6 +306,7 @@   rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"   ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf -   [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz"+  cp "${PKG}.cabal.hackage" "${PKG}-${VER}/${PKG}.cabal" }  install_pkg () {@@ -308,7 +332,8 @@    if [ ! ${NO_DOCUMENTATION} ]   then-    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} > /dev/null 2>&1+    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} \+        > /dev/null 2>&1     then       echo "Skipping documentation for the ${PKG} package."     else@@ -357,8 +382,10 @@     do_pkg   "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}   else     # Use network < 2.6 && network-uri < 2.6-    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}+    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} \+        ${NETWORK_URI_DUMMY_VER_REGEXP}+    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} \+        ${NETWORK_URI_DUMMY_VER_REGEXP}   fi } @@ -374,11 +401,23 @@ info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP} info_pkg "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-info_pkg "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP}+info_pkg "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP} info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP}+info_pkg "async"        ${ASYNC_VER}   ${ASYNC_VER_REGEXP}+info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \+    ${BASE16_BYTESTRING_VER_REGEXP}+info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \+    ${BASE64_BYTESTRING_VER_REGEXP}+info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \+    ${CRYPTOHASH_SHA256_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}+info_pkg "hackage-security"  ${HACKAGE_SECURITY_VER} \+    ${HACKAGE_SECURITY_VER_REGEXP}  do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} do_pkg   "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP}@@ -394,11 +433,24 @@ do_network_uri_pkg  do_pkg   "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-do_pkg   "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP}-do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP}-do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP}-do_pkg   "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}-do_pkg   "stm"          ${STM_VER}     ${STM_VER_REGEXP}+do_pkg   "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP}+do_pkg   "HTTP"         ${HTTP_VER}       ${HTTP_VER_REGEXP}+do_pkg   "zlib"         ${ZLIB_VER}       ${ZLIB_VER_REGEXP}+do_pkg   "random"       ${RANDOM_VER}     ${RANDOM_VER_REGEXP}+do_pkg   "stm"          ${STM_VER}        ${STM_VER_REGEXP}+do_pkg   "async"        ${ASYNC_VER}      ${ASYNC_VER_REGEXP}+do_pkg   "base16-bytestring" ${BASE16_BYTESTRING_VER} \+    ${BASE16_BYTESTRING_VER_REGEXP}+do_pkg   "base64-bytestring" ${BASE64_BYTESTRING_VER} \+    ${BASE64_BYTESTRING_VER_REGEXP}+do_pkg   "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \+    ${CRYPTOHASH_SHA256_VER_REGEXP}+do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}+do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+do_pkg   "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP}+do_pkg   "hackage-security"  ${HACKAGE_SECURITY_VER} \+    ${HACKAGE_SECURITY_VER_REGEXP}+  install_pkg "cabal-install"
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            1.22.9.0+Version:            1.24.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -21,19 +21,104 @@                     2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>                     2007-2012 Duncan Coutts <duncan@community.haskell.org> Category:           Distribution-Build-type:         Simple+Build-type:         Custom Cabal-Version:      >= 1.10 Extra-Source-Files:   README.md bash-completion/cabal bootstrap.sh changelog+  tests/README.md -  -- Generated with '../Cabal/misc/gen-extra-source-files.sh | sort'-  tests/PackageTests/Freeze/my.cabal+  -- 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/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+  -- END gen-extra-source-files  source-repository head   type:     git   location: https://github.com/haskell/cabal/   subdir:   cabal-install +Flag old-bytestring+  description:  Use bytestring < 0.10.2 and bytestring-builder+  default: False+ Flag old-directory   description:  Use directory < 1.2 and old-time   default:      False@@ -45,12 +130,22 @@ executable cabal     main-is:        Main.hs     ghc-options:    -Wall -fwarn-tabs+    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.CmdBuild+        Distribution.Client.CmdConfigure+        Distribution.Client.CmdRepl+        Distribution.Client.ComponentDeps         Distribution.Client.Config         Distribution.Client.Configure         Distribution.Client.Dependency@@ -63,11 +158,14 @@         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@@ -76,12 +174,18 @@         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         Distribution.Client.FetchUtils+        Distribution.Client.FileMonitor         Distribution.Client.Freeze+        Distribution.Client.GenBounds         Distribution.Client.Get+        Distribution.Client.Glob+        Distribution.Client.GlobalFlags         Distribution.Client.GZipUtils         Distribution.Client.Haddock         Distribution.Client.HttpUtils@@ -95,15 +199,29 @@         Distribution.Client.InstallSymlink         Distribution.Client.JobControl         Distribution.Client.List+        Distribution.Client.Manpage+        Distribution.Client.PackageHash         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils+        Distribution.Client.PkgConfigDb+        Distribution.Client.PlanIndex+        Distribution.Client.ProjectBuilding+        Distribution.Client.ProjectConfig+        Distribution.Client.ProjectConfig.Types+        Distribution.Client.ProjectConfig.Legacy+        Distribution.Client.ProjectOrchestration+        Distribution.Client.ProjectPlanning+        Distribution.Client.ProjectPlanning.Types+        Distribution.Client.ProjectPlanOutput         Distribution.Client.Run+        Distribution.Client.RebuildMonad         Distribution.Client.Sandbox         Distribution.Client.Sandbox.Index         Distribution.Client.Sandbox.PackageEnvironment         Distribution.Client.Sandbox.Timestamp         Distribution.Client.Sandbox.Types+        Distribution.Client.Security.HTTP         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist@@ -113,9 +231,10 @@         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils+        Distribution.Client.Utils.LabeledGraph+        Distribution.Client.Utils.Json         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade-        Distribution.Client.Compat.Environment         Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.FilePerms         Distribution.Client.Compat.Process@@ -126,40 +245,55 @@     -- NOTE: when updating build-depends, don't forget to update version regexps     -- in bootstrap.sh.     build-depends:-        array      >= 0.1      && < 0.6,-        base       >= 4.3      && < 5,+        async      >= 2.0      && < 3,+        array      >= 0.4      && < 0.6,+        base       >= 4.5      && < 5,+        base16-bytestring >= 0.1.1 && < 0.2,+        binary     >= 0.5      && < 0.9,         bytestring >= 0.9      && < 1,-        Cabal      >= 1.22.2   && < 1.23,-        containers >= 0.1      && < 0.6,-        filepath   >= 1.0      && < 1.5,-        HTTP       >= 4000.2.5 && < 4000.4,+        Cabal      >= 1.24     && < 1.25,+        containers >= 0.4      && < 0.6,+        cryptohash-sha256 >= 0.11 && < 0.12,+        filepath   >= 1.3      && < 1.5,+        hashable   >= 1.0      && < 2,+        HTTP       >= 4000.1.5 && < 4000.4,         mtl        >= 2.0      && < 3,-        pretty     >= 1        && < 1.2,+        pretty     >= 1.1      && < 1.2,         random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,-        time       >= 1.1      && < 1.7,-        zlib       >= 0.5.3    && < 0.7+        tar        >= 0.5.0.1  && < 0.6,+        time       >= 1.4      && < 1.7,+        zlib       >= 0.5.3    && < 0.7,+        hackage-security >= 0.5.1 && < 0.6 +    if flag(old-bytestring)+      build-depends: bytestring <  0.10.2, bytestring-builder >= 0.10 && < 1+    else+      build-depends: bytestring >= 0.10.2+     if flag(old-directory)-      build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2,+      build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,                      process   >= 1.0.1.1  && < 1.1.0.2     else       build-depends: directory >= 1.2 && < 1.3,-                     process   >= 1.1.0.2  && < 1.3+                     process   >= 1.1.0.2  && < 1.5      -- NOTE: you MUST include the network dependency even when network-uri     -- is pulled in, otherwise the constraint solver doesn't have enough     -- information     if flag(network-uri)-      build-depends: network-uri >= 2.6, network >= 2.6+      build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.7     else       build-depends: network     >= 2.4 && < 2.6 +    -- Needed for GHC.Generics before GHC 7.6+    if impl(ghc < 7.6)+      build-depends: ghc-prim >= 0.2 && < 0.3+     if os(windows)       build-depends: Win32 >= 2 && < 3-      cpp-options: -DWIN32     else-      build-depends: unix >= 2.0 && < 2.8+      build-depends: unix >= 2.5 && < 2.8      if arch(arm) && impl(ghc < 7.6)        -- older ghc on arm does not support -threaded@@ -177,10 +311,21 @@   hs-source-dirs: tests, .   ghc-options: -Wall -fwarn-tabs   other-modules:+    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.Sandbox+    UnitTests.Distribution.Client.Sandbox.Timestamp+    UnitTests.Distribution.Client.Tar     UnitTests.Distribution.Client.UserConfig+    UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Options   build-depends:         base,         array,@@ -192,16 +337,20 @@         process,         directory,         filepath,+        hashable,         stm,+        tar,         time,         HTTP,         zlib,--        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2 >= 0.3,-        HUnit,-        QuickCheck >= 2.5+        binary,+        random,+        hackage-security,+        tasty,+        tasty-hunit,+        tasty-quickcheck,+        tagged,+        QuickCheck >= 2.8.2    if flag(old-directory)     build-depends: old-time@@ -211,9 +360,11 @@   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-    cpp-options: -DWIN32   else     build-depends: unix @@ -223,36 +374,26 @@     ghc-options: -threaded   default-language: Haskell2010 --- Large, system tests that build packages.-test-suite package-tests+test-suite integration-tests   type: exitcode-stdio-1.0   hs-source-dirs: tests-  main-is: PackageTests.hs-  other-modules:-    PackageTests.Exec.Check-    PackageTests.Freeze.Check-    PackageTests.MultipleSource.Check-    PackageTests.PackageTester+  main-is: IntegrationTests.hs   build-depends:     Cabal,-    HUnit,-    QuickCheck >= 2.1.0.1 && < 2.9,+    async,     base,     bytestring,     directory,-    extensible-exceptions,     filepath,     process,     regex-posix,-    test-framework,-    test-framework-hunit,-    test-framework-quickcheck2 >= 0.2.12+    tasty,+    tasty-hunit    if os(windows)     build-depends: Win32 >= 2 && < 3-    cpp-options: -DWIN32   else-    build-depends: unix >= 2.0 && < 2.8+    build-depends: unix >= 2.5 && < 2.8    if arch(arm)     cc-options:  -DCABAL_NO_THREADED
cbits/getnumcores.c view
@@ -8,7 +8,7 @@  #ifndef HAS_GET_NUMBER_OF_PROCESSORS -#ifdef _WIN32+#if defined(_WIN32) && !defined(__CYGWIN__) #include <windows.h> #elif MACOS #include <sys/param.h>@@ -18,7 +18,7 @@ #endif  int getNumberOfProcessors() {-#ifdef WIN32+#if defined(_WIN32) && !defined(__CYGWIN__)     SYSTEM_INFO sysinfo;     GetSystemInfo(&sysinfo);     return sysinfo.dwNumberOfProcessors;
changelog view
@@ -1,38 +1,65 @@ -*-change-log-*--1.22.9.0 Ryan Thomas <ryan@ryant.org> March 2016-	* Include Cabal-1.22.8.0 -1.22.8.0 Ryan Thomas <ryan@ryant.org> February 2016-	* Only Custom setup scripts should be compiled with '-i -i.'.-	* installedCabalVersion: Don't special-case Cabal anymore.-	* Bump the HTTP upper bound. See #3069.--1.22.7.0-	* Remove GZipUtils tests-	* maybeDecompress: bail on all errors at the beginning of the stream with zlib < 0.6-	* Correct maybeDecompress--1.22.6.0 Ryan Thomas <ryan@ryant.org> June 2015-	* A fix for @ezyang's fix for #2502. (Mikhail Glushenkov)--1.22.5.0 Ryan Thomas <ryan@ryant.org> June 2015-	* Reduce temporary directory name length, fixes #2502. (Edward Z. Yang)--1.22.4.0 Ryan Thomas <ryan@ryant.org> May 2015-	* Force cabal upload to always use digest auth and never basic auth.-	* Add dependency-graph information to `printPlan` output-	* bootstrap.sh: fixes linker matching to avoid cases where tested linker names appear unexpectedly in compiler output (fixes #2542)--1.22.3.0 Ryan Thomas <ryan@ryant.org> April 2015-	* Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov)-	* filterConfigureFlags: filter more flags (Mikhail Glushenkov)--1.22.2.0 Ryan Thomas <ryan@ryant.org> March 2015-	* Don't pass '--{en,dis}able-profiling' to old setup exes.-	* -Wall police-	* Allow filepath 1.4+1.24.0.0 Ryan Thomas <ryan@ryant.org> May 2016+	* If there are multiple remote repos, 'cabal update' now updates+	them in parallel (#2503).+	* New 'cabal upload' option '-P'/'--password-command' for reading+	Hackage password from arbitrary program output (#2506).+	* Better warning for 'cabal run' (#2510).+	* 'cabal init' now warns if the chosen package name is already+	registered in the source package index (#2436).+	* New 'cabal install' option: '--offline' (#2578).+	* Accept 'builddir' field in cabal.config (#2484)+	* Read 'builddir' option from 'CABAL_BUILDDIR' environment variable.+	* Remote repos may now be configured to use https URLs. This uses+	either curl or wget or, on Windows, PowerShell, under the hood (#2687).+	* Install target URLs can now use https e.g. 'cabal install+	https://example.com/foo-1.0.tar.gz'.+	* Automatically use https for cabal upload for the main+	hackage.haskell.org (other repos will use whatever they are+	configured to use).+	* Support for dependencies of custom Setup.hs scripts+	(see http://www.well-typed.com/blog/2015/07/cabal-setup-deps/).+	* 'cabal' program itself now can be used as an external setup+	method. This fixes an issue when Cabal version mismatch caused+	unnecessary reconfigures (#2633).+	* Improved error message for unsatisfiable package constraints+	(#2727).+	* Fixed a space leak in 'cabal update' (#2826).+	* 'cabal exec' and 'sandbox hc-pkg' now use the configured+	compiler (#2859).+	* New 'cabal haddock' option: '--for-hackage' (#2852).+	* Added a warning when the solver cannot find a dependency (#2853).+	* New 'cabal upload' option: '--doc': upload documentation to+	hackage (#2890).+	* Improved error handling for 'sandbox delete-source' (#2943).+	* Solver support for extension and language flavours (#2873).+	* Support for secure repos using hackage-security (#2983).+	* Added a log file message similar to one printed by 'make' when+	building in another directory (#2642).+	* Added new subcommand 'init' to 'cabal user-config'. This+	subcommand creates a cabal configuration file in either the+	default location or as specified by --config-file (#2553).+	* The man page for 'cabal-install' is now automatically generated+	(#2877).+	* The '--allow-newer' option now works as expected when specified+	multiple times (#2588).+	* New config file field: 'extra-framework-dirs' (extra locations+	to find OS X frameworks in). Can be also specified as an argument+	for 'install' and 'configure' commands (#3158).+	* It's now possible to limit the scope of '--allow-newer' to+	single packages in the install plan (#2756).+	* Full '--allow-newer' syntax is now supported in the config file+	(that is, 'allow-newer: base, ghc-prim,  some-package:vector')+	(#3171).+	* Improved performance of '--reorder-goals' (#3208).+	* Fixed space leaks in modular solver (#2916, #2914).+	* Added a new command: 'gen-bounds' (#3223). See+	http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html.+	* Tech preview of new nix-style isolated project-based builds.+	Currently provides the commands (new-)build/repl/configure. -1.21.x (current development version)+1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 	* New command: user-config (#2159). 	* Implement 'cabal repl --only' (#2016). 	* Fix an issue when 'cabal repl' was doing unnecessary compilation
+ tests/IntegrationTests.hs view
@@ -0,0 +1,310 @@+{-# 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/common.sh view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/custom/should_run/plain.err view
@@ -0,0 +1,2 @@+Custom+Custom
+ tests/IntegrationTests/custom/should_run/plain.sh view
@@ -0,0 +1,4 @@+. ../common.sh+cd plain+cabal configure+cabal build
+ tests/IntegrationTests/custom/should_run/plain/A.hs view
@@ -0,0 +1,1 @@+module A where
+ tests/IntegrationTests/custom/should_run/plain/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+import System.IO+main = hPutStrLn stderr "Custom" >> defaultMain
+ tests/IntegrationTests/custom/should_run/plain/plain.cabal view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err view
@@ -0,0 +1,1 @@+RE:^cabal(\.exe)?: Please specify an executable to run$
+ tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh view
@@ -0,0 +1,3 @@+. ../common.sh++cabal exec
+ tests/IntegrationTests/exec/should_run/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++foo :: String+foo = "foo"
+ tests/IntegrationTests/exec/should_run/My.hs view
@@ -0,0 +1,5 @@+module Main where++main :: IO ()+main = do+    putStrLn "This is my-executable"
+ tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out view
@@ -0,0 +1,1 @@+This is my-executable
+ tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh view
@@ -0,0 +1,10 @@+. ../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 view
@@ -0,0 +1,4 @@+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 view
@@ -0,0 +1,2 @@+. ../common.sh+cabal exec echo find_me_in_output
+ tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out view
@@ -0,0 +1,1 @@+This is my-executable
+ tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh view
@@ -0,0 +1,9 @@+. ../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 view
@@ -0,0 +1,14 @@+. ../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 view
@@ -0,0 +1,13 @@+. ../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 view
@@ -0,0 +1,14 @@+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 view
@@ -0,0 +1,1 @@+this string
+ tests/IntegrationTests/exec/should_run/runs_given_command.sh view
@@ -0,0 +1,3 @@+. ../common.sh+cabal configure > /dev/null+cabal exec echo this string
+ tests/IntegrationTests/freeze/common.sh view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh view
@@ -0,0 +1,3 @@+. ../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 view
@@ -0,0 +1,3 @@+. ../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 view
@@ -0,0 +1,5 @@+. ../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 view
@@ -0,0 +1,3 @@+. ../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 view
@@ -0,0 +1,3 @@+. ../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 view
@@ -0,0 +1,4 @@+. ../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 view
@@ -0,0 +1,3 @@+. ../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 view
@@ -0,0 +1,3 @@+. ../common.sh+cabal freeze+grep " base ==" cabal.config || die "'base' should have been frozen"
+ tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh view
@@ -0,0 +1,3 @@+. ../common.sh+cabal freeze+grep " ghc-prim ==" cabal.config || die "'ghc-prim' should have been frozen"
+ tests/IntegrationTests/freeze/should_run/my.cabal view
@@ -0,0 +1,21 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.20.0+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++test-suite test-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Foo.hs+    build-depends: base, my, test-framework++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    benchmark-Foo.hs+    build-depends: base, my, criterion
+ tests/IntegrationTests/freeze/should_run/runs_without_error.sh view
@@ -0,0 +1,2 @@+. ../common.sh+cabal freeze
+ tests/IntegrationTests/manpage/common.sh view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/manpage/should_run/outputs_manpage.sh view
@@ -0,0 +1,11 @@+. ../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 view
@@ -0,0 +1,8 @@+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh view
@@ -0,0 +1,11 @@+. ../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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/multiple-source/should_run/p/p.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/multiple-source/should_run/q/q.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,8 @@+. ./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 view
@@ -0,0 +1,1 @@+module P where
+ tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,4 @@+module Main where+import P+main :: IO ()+main = return ()
+ tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,12 @@+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 view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/regression/t3199.sh view
@@ -0,0 +1,12 @@+. ./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 view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ tests/IntegrationTests/regression/t3199/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/regression/t3199/test-3199.cabal view
@@ -0,0 +1,27 @@+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 view
@@ -0,0 +1,8 @@+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err view
@@ -0,0 +1,3 @@+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 view
@@ -0,0 +1,10 @@+. ../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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal view
@@ -0,0 +1,11 @@+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 view
@@ -0,0 +1,22 @@+. ../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 view
@@ -0,0 +1,6 @@+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 view
@@ -0,0 +1,11 @@+. ../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 view
@@ -0,0 +1,9 @@+# 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 view
@@ -0,0 +1,1 @@+RE:^cabal(\.exe)?: \./cabal-config already exists\.$
+ tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh view
@@ -0,0 +1,6 @@+. ../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 view
@@ -0,0 +1,2 @@+Writing default configuration to ./cabal-config+Writing default configuration to ./cabal-config
+ tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh view
@@ -0,0 +1,9 @@+. ../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 view
@@ -0,0 +1,1 @@+Writing default configuration to ./cabal-config
+ tests/IntegrationTests/user-config/should_run/runs_without_error.sh view
@@ -0,0 +1,7 @@+. ../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 view
@@ -0,0 +1,1 @@+Writing default configuration to ./my-config
+ tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh view
@@ -0,0 +1,5 @@+. ../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/PackageTests.hs 
@@ -1,88 +0,0 @@--- | Groups black-box tests of cabal-install and configures them to test--- the correct binary.------ This file should do nothing but import tests from other modules and run--- them with the path to the correct cabal-install binary.-module Main-       where---- Modules from Cabal.-import Distribution.Simple.Program.Builtin (ghcPkgProgram)-import Distribution.Simple.Program.Db-        (defaultProgramDb, requireProgram, setProgramSearchPath)-import Distribution.Simple.Program.Find-        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)-import Distribution.Simple.Program.Types-        ( Program(..), simpleProgram, programPath)-import Distribution.Simple.Utils ( findProgramVersion )-import Distribution.Verbosity (normal)---- Third party modules.-import qualified Control.Exception.Extensible as E-import System.Directory-        ( canonicalizePath, getCurrentDirectory, setCurrentDirectory-        , removeFile, doesFileExist )-import System.FilePath ((</>))-import Test.Framework (Test, defaultMain, testGroup)-import Control.Monad ( when )---- Module containing common test code.--import PackageTests.PackageTester ( TestsPaths(..)-                                  , packageTestsDirectory-                                  , packageTestsConfigFile )---- Modules containing the tests.-import qualified PackageTests.Exec.Check-import qualified PackageTests.Freeze.Check-import qualified PackageTests.MultipleSource.Check---- List of tests to run. Each test will be called with the path to the--- cabal binary to use.-tests :: PackageTests.PackageTester.TestsPaths -> [Test]-tests paths =-    [ testGroup "Freeze"         $ PackageTests.Freeze.Check.tests         paths-    , testGroup "Exec"           $ PackageTests.Exec.Check.tests           paths-    , testGroup "MultipleSource" $ PackageTests.MultipleSource.Check.tests paths-    ]--cabalProgram :: Program-cabalProgram = (simpleProgram "cabal") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }--main :: IO ()-main = do-    buildDir <- canonicalizePath "dist/build/cabal"-    let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath-    (cabal, _) <- requireProgram normal cabalProgram-                      (setProgramSearchPath programSearchPath defaultProgramDb)-    (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb-    canonicalConfigPath <- canonicalizePath $ "tests" </> packageTestsDirectory--    let testsPaths = TestsPaths {-          cabalPath = programPath cabal,-          ghcPkgPath = programPath ghcPkg,-          configPath = canonicalConfigPath </> packageTestsConfigFile-        }--    putStrLn $ "Using cabal: "   ++ cabalPath  testsPaths-    putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath testsPaths--    cwd <- getCurrentDirectory-    let confFile = packageTestsDirectory </> "cabal-config"-        removeConf = do-          b <- doesFileExist confFile-          when b $ removeFile confFile-    let runTests = do-          setCurrentDirectory "tests"-          removeConf -- assert that there is no existing config file-                     -- (we want deterministic testing with the default-                     --  config values)-          defaultMain $ tests testsPaths-    runTests `E.finally` do-        -- remove the default config file that got created by the tests-        removeConf-        -- Change back to the old working directory so that the tests can be-        -- repeatedly run in `cabal repl` via `:main`.-        setCurrentDirectory cwd
− tests/PackageTests/Exec/Check.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE CPP #-}-module PackageTests.Exec.Check-       ( tests-       ) where---import PackageTests.PackageTester--import Test.Framework                 as TF (Test)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit                     (assertBool)--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (when)-import Data.List (intercalate, isInfixOf)-import System.FilePath ((</>))-import System.Directory (getDirectoryContents)--dir :: FilePath-dir = packageTestsDirectory </> "Exec"--tests :: TestsPaths -> [TF.Test]-tests paths =-    [ testCase "exits with failure if given no argument" $ do-          result <- cabal_exec paths dir []-          assertExecFailed result--    , testCase "prints error message if given no argument" $ do-          result <- cabal_exec paths dir []-          assertExecFailed result-          let output = outputText result-              expected = "specify an executable to run"-              errMsg = "should have requested an executable be specified\n" ++-                       output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "runs the given command" $ do-          result <- cabal_exec paths dir ["echo", "this", "string"]-          assertExecSucceeded result-          let output = outputText result-              expected = "this string"-              errMsg = "should have ran the given command\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "can run executables installed in the sandbox" $ do-          -- Test that an executable installed into the sandbox can be found.-          -- We do this by removing any existing sandbox. Checking that the-          -- executable cannot be found. Creating a new sandbox. Installing-          -- the executable and checking it can be run.--          cleanPreviousBuilds paths-          assertMyExecutableNotFound paths-          assertPackageInstall paths--          result <- cabal_exec paths dir ["my-executable"]-          assertExecSucceeded result-          let output = outputText result-              expected = "This is my-executable"-              errMsg = "should have found a my-executable\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "adds the sandbox bin directory to the PATH" $ do-          cleanPreviousBuilds paths-          assertMyExecutableNotFound paths-          assertPackageInstall paths--          result <- cabal_exec paths dir ["bash", "--", "-c", "my-executable"]-          assertExecSucceeded result-          let output = outputText result-              expected = "This is my-executable"-              errMsg = "should have found a my-executable\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "configures GHC to use the sandbox" $ do-          let libNameAndVersion = "my-0.1"--          cleanPreviousBuilds paths-          assertPackageInstall paths--          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion--          result <- cabal_exec paths dir ["ghc-pkg", "list"]-          assertExecSucceeded result-          let output = outputText result-              errMsg = "my library should have been found"-          assertBool errMsg $-              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)-          --    -- , testCase "can find executables built from the package" $ do--    , testCase "configures cabal to use the sandbox" $ do-          let libNameAndVersion = "my-0.1"--          cleanPreviousBuilds paths-          assertPackageInstall paths--          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion--          result <- cabal_exec paths dir ["bash", "--", "-c", "cd subdir ; cabal sandbox hc-pkg list"]-          assertExecSucceeded result-          let output = outputText result-              errMsg = "my library should have been found"-          assertBool errMsg $-              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)-    ]--cleanPreviousBuilds :: TestsPaths -> IO ()-cleanPreviousBuilds paths = do-    sandboxExists <- not . null . filter (== "cabal.sandbox.config") <$>-                         getDirectoryContents dir-    assertCleanSucceeded   =<< cabal_clean paths dir []-    when sandboxExists $ do-        assertSandboxSucceeded =<< cabal_sandbox paths dir ["delete"]---assertPackageInstall :: TestsPaths -> IO ()-assertPackageInstall paths = do-    assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]-    assertInstallSucceeded =<< cabal_install paths dir []---assertMyExecutableNotFound :: TestsPaths -> IO ()-assertMyExecutableNotFound paths = do-    result <- cabal_exec paths dir ["my-executable"]-    assertExecFailed result-    let output = outputText result-        expected = "cabal: The program 'my-executable' is required but it " ++-                   "could not be found"-        errMsg = "should not have found a my-executable\n" ++ output-    assertBool errMsg $-        expected `isInfixOf` (intercalate " " . lines $ output)----assertMyLibIsNotAvailableOutsideofSandbox :: TestsPaths -> String -> IO ()-assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion = do-    (_, _, output) <- run (Just $ dir) (ghcPkgPath paths) ["list"]-    assertBool "my library should not have been found" $ not $-        libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)
− tests/PackageTests/Freeze/Check.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module PackageTests.Freeze.Check-       ( tests-       ) where--import PackageTests.PackageTester--import Test.Framework                 as TF (Test)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit                     (assertBool)--import qualified Control.Exception.Extensible as E-import Data.List (intercalate, isInfixOf)-import System.Directory (doesFileExist, removeFile)-import System.FilePath ((</>))-import System.IO.Error (isDoesNotExistError)--dir :: FilePath-dir = packageTestsDirectory </> "Freeze"--tests :: TestsPaths -> [TF.Test]-tests paths =-    [ testCase "runs without error" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result--    , testCase "freezes direct dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen base\n" ++ c) $-              " base ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "freezes transitory dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen ghc-prim\n" ++ c) $-              " ghc-prim ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "does not freeze packages which are not dependend upon" $ do-          -- XXX Test this against a package installed in the sandbox but-          -- not depended upon.-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen exceptions\n" ++ c) $ not $-              " exceptions ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "does not include a constraint for the package being frozen" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen self\n" ++ c) $ not $-              " my ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--dry-run does not modify the cabal.config file" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--dry-run"]-          assertFreezeSucceeded result-          c <- doesFileExist $ dir </> "cabal.config"-          assertBool "cabal.config file should not have been created" (not c)--    , testCase "--enable-tests freezes test dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--enable-tests"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen test-framework\n" ++ c) $-              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--disable-tests does not freeze test dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-tests"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen test-framework\n" ++ c) $ not $-              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--enable-benchmarks freezes benchmark dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-benchmarks"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen criterion\n" ++ c) $ not $-              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--disable-benchmarks does not freeze benchmark dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-benchmarks"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen criterion\n" ++ c) $ not $-              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)-    ]--removeCabalConfig :: IO ()-removeCabalConfig = do-    removeFile (dir </> "cabal.config")-    `E.catch` \ (e :: IOError) ->-        if isDoesNotExistError e-        then return ()-        else E.throw e---readCabalConfig :: IO String-readCabalConfig = do-    readFile $ dir </> "cabal.config"
− tests/PackageTests/Freeze/my.cabal 
@@ -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/PackageTests/MultipleSource/Check.hs 
@@ -1,28 +0,0 @@-module PackageTests.MultipleSource.Check-       ( tests-       ) where---import PackageTests.PackageTester--import Test.Framework                 as TF (Test)-import Test.Framework.Providers.HUnit (testCase)--import Control.Monad    (void, when)-import System.Directory (doesDirectoryExist)-import System.FilePath  ((</>))--dir :: FilePath-dir = packageTestsDirectory </> "MultipleSource"--tests :: TestsPaths -> [TF.Test]-tests paths =-    [ testCase "finds second source of multiple source" $ do-          sandboxExists <- doesDirectoryExist $ dir </> ".cabal-sandbox"-          when sandboxExists $-            void $ cabal_sandbox paths dir ["delete"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "p"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "q"]-          assertInstallSucceeded =<< cabal_install paths dir ["q"]-    ]
− tests/PackageTests/PackageTester.hs 
@@ -1,232 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- TODO This module was originally based on the PackageTests.PackageTester--- module in Cabal, however it has a few differences. I suspect that as--- this module ages the two modules will diverge further. As such, I have--- not attempted to merge them into a single module nor to extract a common--- module from them.  Refactor this module and/or Cabal's--- PackageTests.PackageTester to remove commonality.---   2014-05-15 Ben Armston---- | Routines for black-box testing cabal-install.------ Instead of driving the tests by making library calls into--- Distribution.Simple.* or Distribution.Client.* this module only every--- executes the `cabal-install` binary.------ You can set the following VERBOSE environment variable to control--- the verbosity of the output generated by this module.-module PackageTests.PackageTester-    ( TestsPaths(..)-    , Result(..)--    , packageTestsDirectory-    , packageTestsConfigFile--    -- * Running cabal commands-    , cabal_clean-    , cabal_exec-    , cabal_freeze-    , cabal_install-    , cabal_sandbox-    , run--    -- * Test helpers-    , assertCleanSucceeded-    , assertExecFailed-    , assertExecSucceeded-    , assertFreezeSucceeded-    , assertInstallSucceeded-    , assertSandboxSucceeded-    ) where--import qualified Control.Exception.Extensible as E-import Control.Monad (when, unless)-import Data.Maybe (fromMaybe)-import System.Directory (canonicalizePath, doesFileExist)-import System.Environment (getEnv)-import System.Exit (ExitCode(ExitSuccess))-import System.FilePath ( (<.>)  )-import System.IO (hClose, hGetChar, hIsEOF)-import System.IO.Error (isDoesNotExistError)-import System.Process (runProcess, waitForProcess)-import Test.HUnit (Assertion, assertFailure)--import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.Simple.Utils (printRawCommandAndArgs)-import Distribution.Compat.CreatePipe (createPipe)-import Distribution.ReadE (readEOrFail)-import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)--data Success = Failure-             -- | ConfigureSuccess-             -- | BuildSuccess-             -- | TestSuccess-             -- | BenchSuccess-             | CleanSuccess-             | ExecSuccess-             | FreezeSuccess-             | InstallSuccess-             | SandboxSuccess-             deriving (Eq, Show)--data TestsPaths = TestsPaths-    { cabalPath  :: FilePath -- ^ absolute path to cabal executable.-    , ghcPkgPath :: FilePath -- ^ absolute path to ghc-pkg executable.-    , configPath :: FilePath -- ^ absolute path of the default config file-                             --   to use for tests (tests are free to use-                             --   a different one).-    }--data Result = Result-    { successful :: Bool-    , success    :: Success-    , outputText :: String-    } deriving Show--nullResult :: Result-nullResult = Result True Failure ""----------------------------------------------------------------------------- * Config--packageTestsDirectory :: FilePath-packageTestsDirectory = "PackageTests"--packageTestsConfigFile :: FilePath-packageTestsConfigFile = "cabal-config"----------------------------------------------------------------------------- * Running cabal commands--recordRun :: (String, ExitCode, String) -> Success -> Result -> Result-recordRun (cmd, exitCode, exeOutput) thisSucc res =-    res { successful = successful res && exitCode == ExitSuccess-        , success    = if exitCode == ExitSuccess then thisSucc-                       else success res-        , outputText =-            (if null $ outputText res then "" else outputText res ++ "\n") ++-            cmd ++ "\n" ++ exeOutput-        }---- | Run the clean command and return its result.-cabal_clean :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_clean paths dir args = do-    res <- cabal paths dir (["clean"] ++ args)-    return $ recordRun res CleanSuccess nullResult---- | Run the exec command and return its result.-cabal_exec :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_exec paths dir args = do-    res <- cabal paths dir (["exec"] ++ args)-    return $ recordRun res ExecSuccess nullResult---- | Run the freeze command and return its result.-cabal_freeze :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_freeze paths dir args = do-    res <- cabal paths dir (["freeze"] ++ args)-    return $ recordRun res FreezeSuccess nullResult---- | Run the install command and return its result.-cabal_install :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_install paths dir args = do-    res <- cabal paths dir (["install"] ++ args)-    return $ recordRun res InstallSuccess nullResult---- | Run the sandbox command and return its result.-cabal_sandbox :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_sandbox paths dir args = do-    res <- cabal paths dir (["sandbox"] ++ args)-    return $ recordRun res SandboxSuccess nullResult---- | Returns the command that was issued, the return code, and the output text.-cabal :: TestsPaths -> FilePath -> [String] -> IO (String, ExitCode, String)-cabal paths dir cabalArgs = do-    run (Just dir) (cabalPath paths) args-  where-    args = configFileArg : cabalArgs-    configFileArg = "--config-file=" ++ configPath paths---- | Returns the command that was issued, the return code, and the output text-run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)-run cwd path args = do-    verbosity <- getVerbosity-    -- path is relative to the current directory; canonicalizePath makes it-    -- absolute, so that runProcess will find it even when changing directory.-    path' <- do pathExists <- doesFileExist path-                canonicalizePath (if pathExists then path else path <.> exeExtension)-    printRawCommandAndArgs verbosity path' args-    (readh, writeh) <- createPipe-    pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)--    -- fork off a thread to start consuming the output-    out <- suckH [] readh-    hClose readh--    -- wait for the program to terminate-    exitcode <- waitForProcess pid-    let fullCmd = unwords (path' : args)-    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)-  where-    suckH output h = do-        eof <- hIsEOF h-        if eof-            then return (reverse output)-            else do-                c <- hGetChar h-                suckH (c:output) h----------------------------------------------------------------------------- * Test helpers--assertCleanSucceeded :: Result -> Assertion-assertCleanSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal clean\' should succeed\n" ++-    "  output: " ++ outputText result--assertExecSucceeded :: Result -> Assertion-assertExecSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal exec\' should succeed\n" ++-    "  output: " ++ outputText result--assertExecFailed :: Result -> Assertion-assertExecFailed result = when (successful result) $-    assertFailure $-    "expected: \'cabal exec\' should fail\n" ++-    "  output: " ++ outputText result--assertFreezeSucceeded :: Result -> Assertion-assertFreezeSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal freeze\' should succeed\n" ++-    "  output: " ++ outputText result--assertInstallSucceeded :: Result -> Assertion-assertInstallSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal install\' should succeed\n" ++-    "  output: " ++ outputText result--assertSandboxSucceeded :: Result -> Assertion-assertSandboxSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal sandbox\' should succeed\n" ++-    "  output: " ++ outputText result----------------------------------------------------------------------------- Verbosity--lookupEnv :: String -> IO (Maybe String)-lookupEnv name =-    (fmap Just $ getEnv name)-    `E.catch` \ (e :: IOError) ->-        if isDoesNotExistError e-        then return Nothing-        else E.throw e---- TODO: Convert to a "-v" flag instead.-getVerbosity :: IO Verbosity-getVerbosity = do-    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"
+ tests/README.md view
@@ -0,0 +1,27 @@+Integration Tests+=================++Each test is a shell script.  Tests that share files (e.g., `.cabal` files) are+grouped under a common sub-directory of [IntegrationTests].  The framework+copies the whole group's directory before running each test, which allows tests+to reuse files, yet run independently.  A group's tests are further divided into+`should_run` and `should_fail` directories, based on the expected exit status.+For example, the test+`IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh` has access+to all files under `exec` and is expected to fail.++Tests can specify their expected output.  For a test named `x.sh`, `x.out`+specifies `stdout` and `x.err` specifies `stderr`.  Both files are optional.+The framework expects an exact match between lines in the file and output,+except for lines beginning with "RE:", which are interpreted as regular+expressions.++[IntegrationTests.hs] defines several environment variables:++* `CABAL` - The path to the executable being tested.+* `GHC_PKG` - The path to ghc-pkg.+* `CABAL_ARGS` - A common set of arguments for running cabal.+* `CABAL_ARGS_NO_CONFIG_FILE` - `CABAL_ARGS` without `--config-file`.++[IntegrationTests]: IntegrationTests+[IntegrationTests.hs]: IntegrationTests.hs
tests/UnitTests.hs view
@@ -1,24 +1,106 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Main        where -import Test.Framework+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 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.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.UserConfig+import qualified UnitTests.Distribution.Client.Sandbox.Timestamp+import qualified UnitTests.Distribution.Client.Tar import qualified UnitTests.Distribution.Client.Targets-import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ+import qualified UnitTests.Distribution.Client.UserConfig+import qualified UnitTests.Distribution.Client.ProjectConfig -tests :: [Test]-tests = [-   testGroup "UnitTests.Distribution.Client.UserConfig"-       UnitTests.Distribution.Client.UserConfig.tests-  ,testGroup "Distribution.Client.Sandbox"+import UnitTests.Options+++tests :: Int -> TestTree+tests mtimeChangeCalibrated =+  askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->+  let mtimeChange = if mtimeChangeProvided /= 0+                    then mtimeChangeProvided+                    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.Client.FileMonitor" $+        UnitTests.Distribution.Client.FileMonitor.tests mtimeChange+  , testGroup "UnitTests.Distribution.Client.Glob"+        UnitTests.Distribution.Client.Glob.tests+  , testGroup "Distribution.Client.GZipUtils"+       UnitTests.Distribution.Client.GZipUtils.tests+  , testGroup "Distribution.Client.Sandbox"        UnitTests.Distribution.Client.Sandbox.tests-  ,testGroup "Distribution.Client.Targets"+  , testGroup "Distribution.Client.Sandbox.Timestamp"+       UnitTests.Distribution.Client.Sandbox.Timestamp.tests+  , testGroup "Distribution.Client.Tar"+       UnitTests.Distribution.Client.Tar.tests+  , testGroup "Distribution.Client.Targets"        UnitTests.Distribution.Client.Targets.tests-  ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"-        UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests+  , testGroup "UnitTests.Distribution.Client.UserConfig"+       UnitTests.Distribution.Client.UserConfig.tests+  , testGroup "UnitTests.Distribution.Client.ProjectConfig"+       UnitTests.Distribution.Client.ProjectConfig.tests   ]  main :: IO ()-main = defaultMain tests+main = do+  mtimeChangeDelay <- calibrateMtimeChangeDelay+  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++    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
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.ArbitraryInstances (+    adjustSize,+    shortListOf,+    shortListOf1,+    arbitraryFlag,+    ShortToken(..),+    arbitraryShortToken,+    NonMEmpty(..),+    NoShrink(..),+  ) where++import Data.Char+import Data.List+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Control.Applicative+#endif+import Control.Monad++import Distribution.Version+import Distribution.Package+import Distribution.System+import Distribution.Verbosity++import Distribution.Simple.Setup+import Distribution.Simple.InstallDirs++import Distribution.Utils.NubList++import Test.QuickCheck+++adjustSize :: (Int -> Int) -> Gen a -> Gen a+adjustSize adjust gen = sized (\n -> resize (adjust n) gen)++shortListOf :: Int -> Gen a -> Gen [a]+shortListOf bound gen =+    sized $ \n -> do+      k <- choose (0, (n `div` 2) `min` bound)+      vectorOf k gen++shortListOf1 :: Int -> Gen a -> Gen [a]+shortListOf1 bound gen =+    sized $ \n -> do+      k <- choose (1, 1 `max` ((n `div` 2) `min` bound))+      vectorOf k gen++newtype ShortToken = ShortToken { getShortToken :: String }+  deriving Show++instance Arbitrary ShortToken where+  arbitrary =+    ShortToken <$>+      (shortListOf1 5 (choose ('#', '~'))+       `suchThat` (not . ("[]" `isPrefixOf`)))+    --TODO: [code cleanup] need to replace parseHaskellString impl to stop+    -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.+    -- Workaround, don't generate [] as this does not round trip.+++  shrink (ShortToken cs) =+    [ ShortToken cs' | cs' <- shrink cs, not (null cs') ]++arbitraryShortToken :: Gen String+arbitraryShortToken = getShortToken <$> arbitrary++instance Arbitrary Version where+  arbitrary = do+    branch <- shortListOf1 4 $+                frequency [(3, return 0)+                          ,(3, return 1)+                          ,(2, return 2)+                          ,(1, return 3)]+    return (Version branch []) -- deliberate []+    where++  shrink (Version branch []) =+    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]+  shrink (Version branch _tags) =+    [ Version branch [] ]++instance Arbitrary VersionRange where+  arbitrary = canonicaliseVersionRange <$> sized verRangeExp+    where+      verRangeExp n = frequency $+        [ (2, return anyVersion)+        , (1, liftM thisVersion arbitrary)+        , (1, liftM laterVersion arbitrary)+        , (1, liftM orLaterVersion arbitrary)+        , (1, liftM orLaterVersion' arbitrary)+        , (1, liftM earlierVersion arbitrary)+        , (1, liftM orEarlierVersion arbitrary)+        , (1, liftM orEarlierVersion' arbitrary)+        , (1, liftM withinVersion arbitrary)+        , (2, liftM VersionRangeParens arbitrary)+        ] ++ if n == 0 then [] else+        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)+        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)+        ]+        where+          verRangeExp2 = verRangeExp (n `div` 2)++      orLaterVersion'   v =+        unionVersionRanges (laterVersion v)   (thisVersion v)+      orEarlierVersion' v =+        unionVersionRanges (earlierVersion v) (thisVersion v)++      canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals++instance Arbitrary PackageName where+    arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent+      where+        nameComponent = shortListOf1 5 (elements packageChars)+                        `suchThat` (not . all isDigit)+        packageChars  = filter isAlphaNum ['\0'..'\127']++instance Arbitrary Dependency where+    arbitrary = Dependency <$> arbitrary <*> arbitrary++instance Arbitrary OS where+    arbitrary = elements knownOSs++instance Arbitrary Arch where+    arbitrary = elements knownArches++instance Arbitrary Platform where+    arbitrary = Platform <$> arbitrary <*> arbitrary++instance Arbitrary a => Arbitrary (Flag a) where+    arbitrary = arbitraryFlag arbitrary+    shrink NoFlag   = []+    shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ]++arbitraryFlag :: Gen a -> Gen (Flag a)+arbitraryFlag genA =+    sized $ \sz ->+      case sz of+        0 -> pure NoFlag+        _ -> frequency [ (1, pure NoFlag)+                       , (3, Flag <$> genA) ]+++instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where+    arbitrary = toNubList <$> arbitrary+    shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ]+    -- try empty, otherwise don't shrink as it can loop++instance Arbitrary Verbosity where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary PathTemplate where+    arbitrary = toPathTemplate <$> arbitraryShortToken+    shrink t  = [ toPathTemplate s | s <- shrink (show t), not (null s) ]+++newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }+  deriving (Eq, Ord, Show)++instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where+  arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))+  shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]++newtype NoShrink a = NoShrink { getNoShrink :: a }+  deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (NoShrink a) where+    arbitrary = NoShrink <$> arbitrary+    shrink _  = []+
+ tests/UnitTests/Distribution/Client/Compat/Time.hs view
@@ -0,0 +1,49 @@+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 view
@@ -0,0 +1,418 @@+{-# 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 view
@@ -4,10 +4,10 @@  import Distribution.Client.Dependency.Modular.PSQ -import Test.Framework as TF (Test)-import Test.Framework.Providers.QuickCheck2+import Test.Tasty+import Test.Tasty.QuickCheck -tests :: [TF.Test]+tests :: [TestTree] tests = [ testProperty "splitsAltImplementation" splitsTest         ]
+ tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs view
@@ -0,0 +1,805 @@+{-# 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
@@ -0,0 +1,769 @@+module UnitTests.Distribution.Client.FileMonitor (tests) where++import Control.Monad+import Control.Exception+import Control.Concurrent (threadDelay)+import qualified Data.Set as Set+import System.FilePath+import qualified System.Directory as IO+import Prelude hiding (writeFile)+import qualified Prelude as IO (writeFile)++import Distribution.Text (simpleParse)+import Distribution.Compat.Binary+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)++import Distribution.Client.FileMonitor+import Distribution.Client.Compat.Time++import Test.Tasty+import Test.Tasty.HUnit+++tests :: Int -> [TestTree]+tests mtimeChange =+  [ testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange+  , testCase "no monitor cache"      testNoMonitorCache+  , testCase "corrupt monitor cache" testCorruptMonitorCache+  , testCase "empty monitor"         testEmptyMonitor+  , testCase "missing file"          testMissingFile+  , testCase "change file"           $ testChangedFile mtimeChange+  , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange+  , testCase "update during action"  $ testUpdateDuringAction mtimeChange+  , testCase "remove file"           testRemoveFile+  , testCase "non-existent file"     testNonExistentFile+  , testCase "changed file type"     $ testChangedFileType mtimeChange++  , testGroup "glob matches"+    [ testCase "no change"           testGlobNoChange+    , testCase "add match"           $ testGlobAddMatch mtimeChange+    , testCase "remove match"        $ testGlobRemoveMatch mtimeChange+    , testCase "change match"        $ testGlobChangeMatch mtimeChange++    , testCase "add match subdir"    $ testGlobAddMatchSubdir mtimeChange+    , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange+    , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange++    , testCase "match toplevel dir"  $ testGlobMatchTopDir mtimeChange+    , testCase "add non-match"       $ testGlobAddNonMatch mtimeChange+    , testCase "remove non-match"    $ testGlobRemoveNonMatch mtimeChange++    , testCase "add non-match"       $ testGlobAddNonMatchSubdir mtimeChange+    , testCase "remove non-match"    $ testGlobRemoveNonMatchSubdir mtimeChange++    , testCase "invariant sorted 1"  $ testInvariantMonitorStateGlobFiles+                                         mtimeChange+    , testCase "invariant sorted 2"  $ testInvariantMonitorStateGlobDirs+                                         mtimeChange++    , testCase "match dirs"          $ testGlobMatchDir mtimeChange+    , testCase "match dirs only"     $ testGlobMatchDirOnly mtimeChange+    , testCase "change file type"    $ testGlobChangeFileType mtimeChange+    , testCase "absolute paths"      $ testGlobAbsolutePath mtimeChange+    ]++  , testCase "value unchanged"       testValueUnchanged+  , testCase "value changed"         testValueChanged+  , testCase "value & file changed"  $ testValueAndFileChanged mtimeChange+  , testCase "value updated"         testValueUpdated+  ]++-- we rely on file mtimes having a reasonable resolution+testFileMTimeSanity :: Int -> Assertion+testFileMTimeSanity mtimeChange =+  withTempDirectory silent "." "file-status-" $ \dir -> do+    replicateM_ 10 $ do+      IO.writeFile (dir </> "a") "content"+      t1 <- getModTime (dir </> "a")+      threadDelay mtimeChange+      IO.writeFile (dir </> "a") "content"+      t2 <- getModTime (dir </> "a")+      assertBool "expected different file mtimes" (t2 > t1)++-- first run, where we don't even call updateMonitor+testNoMonitorCache :: Assertion+testNoMonitorCache =+  withFileMonitor $ \root monitor -> do+    reason <- expectMonitorChanged root (monitor :: FileMonitor () ()) ()+    reason @?= MonitorFirstRun++-- write garbage into the binary cache file+testCorruptMonitorCache :: Assertion+testCorruptMonitorCache =+  withFileMonitor $ \root monitor -> do+    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitorCorruptCache++    updateMonitor root monitor [] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitorCorruptCache++-- no files to monitor+testEmptyMonitor :: Assertion+testEmptyMonitor =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [] () ()+    touchFile root "b"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++-- monitor a file that is expected to exist+testMissingFile :: Assertion+testMissingFile = do+    test monitorFile       touchFile  "a"+    test monitorFileHashed touchFile  "a"+    test monitorFile       touchFile ("dir" </> "a")+    test monitorFileHashed touchFile ("dir" </> "a")+    test monitorDirectory  touchDir   "a"+    test monitorDirectory  touchDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch file =+      withFileMonitor $ \root monitor -> do+        -- a file that doesn't exist at snapshot time is considered to have+        -- changed+        updateMonitor root monitor [monitorKind file] () ()+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file++        -- a file doesn't exist at snapshot time, but gets added afterwards is+        -- also considered to have changed+        updateMonitor root monitor [monitorKind file] () ()+        touch root file+        reason2 <- expectMonitorChanged root monitor ()+        reason2 @?= MonitoredFileChanged file+++testChangedFile :: Int -> Assertion+testChangedFile mtimeChange = do+    test monitorFile       touchFile touchFile         "a"+    test monitorFileHashed touchFile touchFileContent  "a"+    test monitorFile       touchFile touchFile        ("dir" </> "a")+    test monitorFileHashed touchFile touchFileContent ("dir" </> "a")+    test monitorDirectory  touchDir  touchDir          "a"+    test monitorDirectory  touchDir  touchDir         ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch touch' file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        threadDelay mtimeChange+        touch' root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testChangedFileMtimeVsContent :: Int -> Assertion+testChangedFileMtimeVsContent mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- if we don't touch the file, it's unchanged+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a"]++    -- if we do touch the file, it's changed if we only consider mtime+    updateMonitor root monitor [monitorFile "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- but if we touch the file, it's unchanged if we consider content hash+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorFileHashed "a"]++    -- finally if we change the content it's changed+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFileContent root "a"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"+++testUpdateDuringAction :: Int -> Assertion+testUpdateDuringAction mtimeChange = do+    test (monitorFile        "a") touchFile "a"+    test (monitorFileHashed  "a") touchFile "a"+    test (monitorDirectory   "a") touchDir  "a"+    test (monitorFileGlobStr "*") touchFile "a"+    test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }+                                  touchDir  "a"+  where+    test :: MonitorFilePath+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorSpec touch file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorSpec] () ()++        -- start doing an update action...+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitor root monitor [monitorSpec] () ()+        -- we don't notice this change since we took the timestamp after the+        -- action finished+        (res, files) <- expectMonitorUnchanged root monitor ()+        res   @?= ()+        files @?= [monitorSpec]++        -- Let's try again, this time taking the timestamp before the action+        timestamp' <- beginUpdateFileMonitor+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () ()+        -- now we do notice the change since we took the snapshot before the+        -- action finished+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testRemoveFile :: Assertion+testRemoveFile = do+    test monitorFile       touchFile removeFile  "a"+    test monitorFileHashed touchFile removeFile  "a"+    test monitorFile       touchFile removeFile ("dir" </> "a")+    test monitorFileHashed touchFile removeFile ("dir" </> "a")+    test monitorDirectory  touchDir  removeDir   "a"+    test monitorDirectory  touchDir  removeDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch remove file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        remove root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++-- monitor a file that we expect not to exist+testNonExistentFile :: Assertion+testNonExistentFile =+  withFileMonitor $ \root monitor -> do+    -- a file that doesn't exist at snapshot time or check time is unchanged+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorNonExistentFile "a"]++    -- if the file then exists it has changed+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- if the file then exists at snapshot and check time it has changed+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"++    -- but if the file existed at snapshot time and doesn't exist at check time+    -- it is consider unchanged. This is unlike files we expect to exist, but+    -- that's because files that exist can have different content and actions+    -- can depend on that content, whereas if the action expected a file not to+    -- exist and it now does not, it'll give the same result, irrespective of+    -- the fact that the file might have existed in the meantime.+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    removeFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorNonExistentFile "a"]+++testChangedFileType :: Int-> Assertion+testChangedFileType mtimeChange = do+    test (monitorFile            "a") touchFile removeFile createDir+    test (monitorFileHashed      "a") touchFile removeFile createDir++    test (monitorDirectory       "a") createDir removeDir touchFile+    test (monitorFileOrDirectory "a") createDir removeDir touchFile++    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      touchFile removeFile createDir+    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      createDir removeDir touchFile+  where+    test :: MonitorFilePath+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> IO ()+    test monitorKind touch remove touch' =+      withFileMonitor $ \root monitor -> do+        touch  root "a"+        updateMonitor root monitor [monitorKind] () ()+        threadDelay mtimeChange+        remove root "a"+        touch' root "a"+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged "a"+++------------------+-- globs+--++testGlobNoChange :: Assertion+testGlobNoChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddMatch :: Int -> Assertion+testGlobAddMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobRemoveMatch :: Int -> Assertion+testGlobRemoveMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-a")++testGlobChangeMatch :: Int -> Assertion+testGlobChangeMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++    touchFileContent root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobAddMatchSubdir :: Int -> Assertion+testGlobAddMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++testGlobRemoveMatchSubdir :: Int -> Assertion+testGlobRemoveMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")++testGlobChangeMatchSubdir :: Int -> Assertion+testGlobChangeMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++    touchFileContent root "dir/b/good-b"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++-- check nothing goes squiffy with matching in the top dir+testGlobMatchTopDir :: Int -> Assertion+testGlobMatchTopDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "*"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++testGlobAddNonMatch :: Int -> Assertion+testGlobAddNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobRemoveNonMatch :: Int -> Assertion+testGlobRemoveNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/bad"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddNonMatchSubdir :: Int -> Assertion+testGlobAddNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++testGlobRemoveNonMatchSubdir :: Int -> Assertion+testGlobRemoveNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]+++-- try and tickle a bug that happens if we don't maintain the invariant that+-- MonitorStateGlobFiles entries are sorted+testInvariantMonitorStateGlobFiles :: Int -> Assertion+testInvariantMonitorStateGlobFiles mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "d")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- so there should be no change (since we're doing content checks)+    -- but if we can get the dir entries to appear in the wrong order+    -- then if the sorted invariant is not maintained then we can fool+    -- the 'probeGlobStatus' into thinking there's changes+    removeFile root ("dir" </> "a")+    removeFile root ("dir" </> "b")+    removeFile root ("dir" </> "c")+    removeFile root ("dir" </> "d")+    touchFile root ("dir" </> "d")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]++-- same thing for the subdirs case+testInvariantMonitorStateGlobDirs :: Int -> Assertion+testInvariantMonitorStateGlobDirs mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "d" </> "file")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    removeDir root ("dir" </> "b")+    removeDir root ("dir" </> "c")+    removeDir root ("dir" </> "d")+    touchFile root ("dir" </> "d" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "a" </> "file")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/file"]++-- ensure that a glob can match a directory as well as a file+testGlobMatchDir :: Int -> Assertion+testGlobMatchDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    createDir root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- nothing changed yet+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]+    -- expect dir/b to match and be detected as changed+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")+    -- now remove dir/a and expect it to be detected as changed+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobMatchDirOnly :: Int -> Assertion+testGlobMatchDirOnly mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () ()+    threadDelay mtimeChange+    -- expect file dir/a to not match, so not detected as changed+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/"]+    -- note that checking the file monitor for changes can updates the+    -- cached dir mtimes (when it has to record that there's new matches)+    -- so we need an extra mtime delay+    threadDelay mtimeChange+    -- but expect dir/b to match+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")++testGlobChangeFileType :: Int -> Assertion+testGlobChangeFileType mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- change file to dir+    touchFile root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeFile root ("dir" </> "a")+    createDir  root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a")+    -- change dir to file+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    touchFile root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobAbsolutePath :: Int -> Assertion+testGlobAbsolutePath mtimeChange =+  withFileMonitor $ \root monitor -> do+    root' <- absoluteRoot root+    -- absolute glob, removing a file+    touchFile root ("dir/good-a")+    touchFile root ("dir/good-b")+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged (root' </> "dir/good-a")+    -- absolute glob, adding a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFile root ("dir/good-a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged (root' </> "dir/good-a")+    -- absolute glob, changing a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFileContent root "dir/good-b"+    reason3 <- expectMonitorChanged root monitor ()+    reason3 @?= MonitoredFileChanged (root' </> "dir/good-b")+++------------------+-- value changes+--++testValueUnchanged :: Assertion+testValueUnchanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    (res, files) <- expectMonitorUnchanged root monitor 42+    res   @?= "ok"+    files @?= [monitorFile "a"]++testValueChanged :: Assertion+testValueChanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++testValueAndFileChanged :: Int -> Assertion+testValueAndFileChanged mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    -- we change the value and the file, and the value change is reported+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++    -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed+    -- then it's reported as MonitoredValueChanged+    let monitor' :: FileMonitor Int String+        monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True }+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    reason2 <- expectMonitorChanged root monitor' 43+    reason2 @?= MonitoredValueChanged 42++    -- but if a file changed too then we don't report MonitoredValueChanged+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason3 <- expectMonitorChanged root monitor' 43+    reason3 @?= MonitoredFileChanged "a"++testValueUpdated :: Assertion+testValueUpdated =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    let monitor' :: FileMonitor (Set.Set Int) String+        monitor' = (monitor :: FileMonitor (Set.Set Int) String) {+                     fileMonitorCheckIfOnlyValueChanged = True,+                     fileMonitorKeyValid = Set.isSubsetOf+                   }++    updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok"+    (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])+    res @?= "ok"++    reason <- expectMonitorChanged root monitor' (Set.fromList [42,44])+    reason @?= MonitoredValueChanged (Set.fromList [42,43])+++-------------+-- Utils++newtype RootPath = RootPath FilePath++touchFile :: RootPath -> FilePath -> IO ()+touchFile (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "touched"++touchFileContent :: RootPath -> FilePath -> IO ()+touchFileContent (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "different"++removeFile :: RootPath -> FilePath -> IO ()+removeFile (RootPath root) fname = IO.removeFile (root </> fname)++touchDir :: RootPath -> FilePath -> IO ()+touchDir root@(RootPath rootdir) dname = do+  IO.createDirectoryIfMissing True (rootdir </> dname)+  touchFile  root (dname </> "touch")+  removeFile root (dname </> "touch")++createDir :: RootPath -> FilePath -> IO ()+createDir (RootPath root) dname = do+  let path = root </> dname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.createDirectory path++removeDir :: RootPath -> FilePath -> IO ()+removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root </> dname)++absoluteRoot :: RootPath -> IO FilePath+absoluteRoot (RootPath root) = IO.canonicalizePath root++monitorFileGlobStr :: String -> MonitorFilePath+monitorFileGlobStr globstr+  | Just glob <- simpleParse globstr = monitorFileGlob glob+  | otherwise                        = error $ "Failed to parse " ++ globstr+++expectMonitorChanged :: (Binary a, Binary b)+                     => RootPath -> FileMonitor a b -> a+                     -> IO (MonitorChangedReason a)+expectMonitorChanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged reason -> return reason+    MonitorUnchanged _ _  -> throwIO $ HUnitFailure "expected change"++expectMonitorUnchanged :: (Binary a, Binary b)+                        => RootPath -> FileMonitor a b -> a+                        -> IO (b, [MonitorFilePath])+expectMonitorUnchanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged _reason   -> throwIO $ HUnitFailure "expected no change"+    MonitorUnchanged b files -> return (b, files)++checkChanged :: (Binary a, Binary b)+             => RootPath -> FileMonitor a b+             -> a -> IO (MonitorChanged a b)+checkChanged (RootPath root) monitor key =+  checkFileMonitorChanged monitor root key++updateMonitor :: (Binary a, Binary b)+              => RootPath -> FileMonitor a b+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitor (RootPath root) monitor files key result =+  updateFileMonitor monitor root Nothing files key result++updateMonitorWithTimestamp :: (Binary a, Binary b)+              => RootPath -> FileMonitor a b -> MonitorTimestamp+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =+  updateFileMonitor monitor root (Just timestamp) files key result++withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c+withFileMonitor action = do+  withTempDirectory silent "." "file-status-" $ \root -> do+    let file    = root <.> "monitor"+        monitor = newFileMonitor file+    finally (action (RootPath root) monitor) $ do+      exists <- IO.doesFileExist file+      when exists $ IO.removeFile file
+ tests/UnitTests/Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,60 @@+module UnitTests.Distribution.Client.GZipUtils (+  tests+  ) where++import Codec.Compression.GZip          as GZip+import Codec.Compression.Zlib          as Zlib+import Control.Exception.Base                  (evaluate)+import Control.Exception                       (try, SomeException)+import Control.Monad                           (void)+import Data.ByteString                as BS    (null)+import Data.ByteString.Lazy           as BSL   (pack, toChunks)+import Data.ByteString.Lazy.Char8     as BSLL  (pack, init, length)+import Data.Monoid                             ((<>))+import Distribution.Client.GZipUtils           (maybeDecompress)+import Data.Word                               (Word8)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testCase "maybeDecompress" maybeDecompressUnitTest+        -- "decompress plain" property is non-trivial to state,+        -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process+        -- generating such input would essentially duplicate maybeDecompress implementation+        , testProperty "decompress zlib"  prop_maybeDecompress_zlib+        , testProperty "decompress gzip"  prop_maybeDecompress_gzip+        ]++maybeDecompressUnitTest :: Assertion+maybeDecompressUnitTest =+        assertBool "decompress plain"            (maybeDecompress original              == original)+     >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original)+     >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original)+     >> assertBool "decompress zlib"             (maybeDecompress compressedZlib        == original)+     >> assertBool "decompress gzip"             (maybeDecompress compressedGZip        == original)+     >> assertBool "have no empty chunks"        (Prelude.all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib)+     >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft)+  where+    original = BSLL.pack "original uncompressed input"+    compressedZlib = Zlib.compress original+    compressedGZip = GZip.compress original++    runBrokenStream :: IO (Either SomeException ())+    runBrokenStream = try . void . evaluate . BSLL.length $ maybeDecompress (BSLL.init compressedZlib <> BSLL.pack "*")++prop_maybeDecompress_zlib :: [Word8] -> Property+prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original+  where original = BSL.pack ws+        compressedZlib = Zlib.compress original++prop_maybeDecompress_gzip :: [Word8] -> Property+prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original+  where original = BSL.pack ws+        compressedGZip = GZip.compress original++-- (Only available from "Data.Either" since 7.8.)+isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True
+ tests/UnitTests/Distribution/Client/Glob.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.Glob (tests) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Char+import Data.List+import Distribution.Text (display, parse, simpleParse)+import Distribution.Compat.ReadP++import Distribution.Client.Glob+import UnitTests.Distribution.Client.ArbitraryInstances++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Control.Exception+++tests :: [TestTree]+tests =+  [ testProperty "print/parse roundtrip" prop_roundtrip_printparse+  , testCase     "parse examples"        testParseCases+  ]++--TODO: [nice to have] tests for trivial globs, tests for matching,+-- tests for windows style file paths++prop_roundtrip_printparse :: FilePathGlob -> Bool+prop_roundtrip_printparse pathglob =+  -- can't use simpleParse because it mis-handles trailing spaces+  case [ x | (x, []) <- readP_to_S parse (display pathglob) ] of+    xs@(_:_) -> last xs == pathglob+    _        -> False++-- first run, where we don't even call updateMonitor+testParseCases :: Assertion+testParseCases = do++  FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"+  FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/"++  FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"+  FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"+  FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"+  FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "."]) <- testparse "."++  FilePathGlob FilePathRelative+    (GlobFile [Literal "~"]) <- testparse "~"++  FilePathGlob FilePathRelative+    (GlobDir  [Literal "."] GlobDirTrailing) <- testparse "./"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo"]) <- testparse "foo"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobFile [Literal "bar"])) <- testparse "foo/bar"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"++  FilePathGlob (FilePathRoot "/")+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard]) <- testparse "*"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid++  FilePathGlob FilePathRelative+    (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar"++  FilePathGlob FilePathRelative+    (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}"++  parseFail "{"+  parseFail "}"+  parseFail ","+  parseFail "{"+  parseFail "{{}"+  parseFail "{}"+  parseFail "{,}"+  parseFail "{foo,}"+  parseFail "{,foo}"++  return ()++testparse :: String -> IO FilePathGlob+testparse s =+    case simpleParse s of+      Just p  -> return p+      Nothing -> throwIO $ HUnitFailure ("expected parse of: " ++ s)++parseFail :: String -> Assertion+parseFail s =+    case simpleParse s :: Maybe FilePathGlob of+      Just _  -> throwIO $ HUnitFailure ("expected no parse of: " ++ s)+      Nothing -> return ()++instance Arbitrary FilePathGlob where+  arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary)+                `suchThat` validFilePathGlob++  shrink (FilePathGlob root pathglob) =+    [ FilePathGlob root' pathglob'+    | (root', pathglob') <- shrink (root, pathglob)+    , validFilePathGlob (FilePathGlob root' pathglob') ]++validFilePathGlob :: FilePathGlob -> Bool+validFilePathGlob (FilePathGlob FilePathRelative pathglob) =+  case pathglob of+    GlobDirTrailing             -> False+    GlobDir [Literal "~"] _     -> False+    GlobDir [Literal (d:":")] _ +      | isLetter d              -> False+    _                           -> True+validFilePathGlob _ = True++instance Arbitrary FilePathRoot where+  arbitrary =+    frequency+      [ (3, pure FilePathRelative)+      , (1, pure (FilePathRoot unixroot))+      , (1, FilePathRoot <$> windrive)+      , (1, pure FilePathHomeDir)+      ]+    where+      unixroot = "/"+      windrive = do d <- choose ('A', 'Z'); return (d : ":\\")++  shrink FilePathRelative     = []+  shrink (FilePathRoot _)     = [FilePathRelative]+  shrink FilePathHomeDir      = [FilePathRelative]+++instance Arbitrary FilePathGlobRel where+  arbitrary = sized $ \sz ->+    oneof $ take (max 1 sz)+      [ pure GlobDirTrailing+      , GlobFile  <$> (getGlobPieces <$> arbitrary)+      , GlobDir   <$> (getGlobPieces <$> arbitrary)+                  <*> resize (sz `div` 2) arbitrary+      ]++  shrink GlobDirTrailing = []+  shrink (GlobFile glob) =+      GlobDirTrailing+    : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ]+  shrink (GlobDir glob pathglob) =+      pathglob+    : GlobFile glob+    : [ GlobDir (getGlobPieces glob') pathglob'+      | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ]++newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] }+  deriving Eq++instance Arbitrary GlobPieces where+  arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary++  shrink (GlobPieces glob) =+    [ GlobPieces (mergeLiterals (getNonEmpty glob'))+    | glob' <- shrink (NonEmpty glob) ]++mergeLiterals :: [GlobPiece] -> [GlobPiece]+mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps)+mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps+mergeLiterals (p:ps) = p : mergeLiterals ps+mergeLiterals []     = []++instance Arbitrary GlobPiece where+  arbitrary = sized $ \sz ->+    frequency+      [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars))+      , (1, pure WildCard)+      , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary)))+      ]++  shrink (Literal str) = [ Literal str'+                         | str' <- shrink str+                         , not (null str')+                         , all (`elem` globLiteralChars) str' ]+  shrink WildCard       = []+  shrink (Union as)     = [ Union (map getGlobPieces (getNonEmpty as'))+                          | as' <- shrink (NonEmpty (map GlobPieces as)) ]++globLiteralChars :: [Char]+globLiteralChars = ['\0'..'\128'] \\ "*{},/\\"+
+ tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.ProjectConfig (tests) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Control.Applicative+#endif+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List++import Distribution.Package+import Distribution.PackageDescription hiding (Flag)+import Distribution.Compiler+import Distribution.Version+import Distribution.ParseUtils+import Distribution.Simple.Compiler+import Distribution.Simple.Setup+import Distribution.Simple.InstallDirs+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Simple.Utils+import Distribution.Simple.Program.Types+import Distribution.Simple.Program.Db++import Distribution.Client.Types+import Distribution.Client.Dependency.Types+import Distribution.Client.BuildReports.Types+import Distribution.Client.Targets+import Distribution.Utils.NubList+import Network.URI++import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectConfig.Legacy++import UnitTests.Distribution.Client.ArbitraryInstances++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+  [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $+    [ testProperty "packages"  prop_roundtrip_legacytypes_packages+    , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly+    , testProperty "specific"  prop_roundtrip_legacytypes_specific+    ] +++    -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older+    -- unclear why as of yet+    concat+    [ [ testProperty "shared"    prop_roundtrip_legacytypes_shared+      , testProperty "local"     prop_roundtrip_legacytypes_local+      , testProperty "all"       prop_roundtrip_legacytypes_all+      ]+    | not usingGhc76orOlder+    ]++  , testGroup "individual parser tests"+    [ testProperty "package location"  prop_parsePackageLocationTokenQ+    ]++  , testGroup "ProjectConfig printing/parsing round trip"+    [ testProperty "packages"  prop_roundtrip_printparse_packages+    , testProperty "buildonly" prop_roundtrip_printparse_buildonly+    , testProperty "shared"    prop_roundtrip_printparse_shared+    , testProperty "local"     prop_roundtrip_printparse_local+    , testProperty "specific"  prop_roundtrip_printparse_specific+    , testProperty "all"       prop_roundtrip_printparse_all+    ]+  ]+  where+    usingGhc76orOlder =+      case buildCompilerId of+        CompilerId GHC v -> v < Version [7,7] []+        _                -> False+++------------------------------------------------+-- Round trip: conversion to/from legacy types+--++roundtrip :: Eq a => (a -> b) -> (b -> a) -> a -> Bool+roundtrip f f_inv x =+    (f_inv . f) x == x++roundtrip_legacytypes :: ProjectConfig -> Bool+roundtrip_legacytypes =+    roundtrip convertToLegacyProjectConfig+              convertLegacyProjectConfig+++prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool+prop_roundtrip_legacytypes_all =+    roundtrip_legacytypes++prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool+prop_roundtrip_legacytypes_packages config =+    roundtrip_legacytypes+      config {+        projectConfigBuildOnly       = mempty,+        projectConfigShared          = mempty,+        projectConfigLocalPackages   = mempty,+        projectConfigSpecificPackage = mempty+      }++prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Bool+prop_roundtrip_legacytypes_buildonly config =+    roundtrip_legacytypes+      mempty { projectConfigBuildOnly = config }++prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Bool+prop_roundtrip_legacytypes_shared config =+    roundtrip_legacytypes+      mempty { projectConfigShared = config }++prop_roundtrip_legacytypes_local :: PackageConfig -> Bool+prop_roundtrip_legacytypes_local config =+    roundtrip_legacytypes+      mempty { projectConfigLocalPackages = config }++prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool+prop_roundtrip_legacytypes_specific config =+    roundtrip_legacytypes+      mempty { projectConfigSpecificPackage = MapMappend config }+++--------------------------------------------+-- Round trip: printing and parsing config+--++roundtrip_printparse :: ProjectConfig -> Bool+roundtrip_printparse config =+    case (fmap convertLegacyProjectConfig+        . parseLegacyProjectConfig+        . showLegacyProjectConfig+        . convertToLegacyProjectConfig)+          config of+      ParseOk _ x -> x == config+      _           -> False+++prop_roundtrip_printparse_all :: ProjectConfig -> Bool+prop_roundtrip_printparse_all config =+    roundtrip_printparse config {+      projectConfigBuildOnly =+        hackProjectConfigBuildOnly (projectConfigBuildOnly config),++      projectConfigShared =+        hackProjectConfigShared (projectConfigShared config)+    }++prop_roundtrip_printparse_packages :: [PackageLocationString]+                                   -> [PackageLocationString]+                                   -> [SourceRepo]+                                   -> [Dependency]+                                   -> Bool+prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =+    roundtrip_printparse+      mempty {+        projectPackages         = map getPackageLocationString pkglocstrs1,+        projectPackagesOptional = map getPackageLocationString pkglocstrs2,+        projectPackagesRepo     = repos,+        projectPackagesNamed    = named+      }++prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Bool+prop_roundtrip_printparse_buildonly config =+    roundtrip_printparse+      mempty {+        projectConfigBuildOnly = hackProjectConfigBuildOnly config+      }++hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly+hackProjectConfigBuildOnly config =+    config {+      -- These two fields are only command line transitory things, not+      -- something to be recorded persistently in a config file+      projectConfigOnlyDeps = mempty,+      projectConfigDryRun   = mempty+    }++prop_roundtrip_printparse_shared :: ProjectConfigShared -> Bool+prop_roundtrip_printparse_shared config =+    roundtrip_printparse+      mempty {+        projectConfigShared = hackProjectConfigShared config+      }++hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared+hackProjectConfigShared config =+    config {+      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 ]+            ambiguous _ = False+         in filter (not . ambiguous) (projectConfigConstraints config)+    }+++prop_roundtrip_printparse_local :: PackageConfig -> Bool+prop_roundtrip_printparse_local config =+    roundtrip_printparse+      mempty {+        projectConfigLocalPackages = config+      }++prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)+                                   -> Bool+prop_roundtrip_printparse_specific config =+    roundtrip_printparse+      mempty {+        projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)+      }+++----------------------------+-- Individual Parser tests +--++prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool+prop_parsePackageLocationTokenQ (PackageLocationString str) =+    case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ+                                         (renderPackageLocationToken str) ] of+      [str'] -> str' == str+      _      -> False+++------------------------+-- Arbitrary instances+--++instance Arbitrary ProjectConfig where+    arbitrary =+      ProjectConfig+        <$> (map getPackageLocationString <$> arbitrary)+        <*> (map getPackageLocationString <$> arbitrary)+        <*> shortListOf 3 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) =+      [ ProjectConfig x0' x1' x2' x3'+                      x4' x5' x6' (MapMappend (fmap getNonMEmpty x7'))+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7'))+          <- shrink ((x0, x1, x2, x3),+                     (x4, x5, x6, fmap NonMEmpty (getMapMappend x7)))+      ]++newtype PackageLocationString+      = PackageLocationString { getPackageLocationString :: String }+  deriving Show++instance Arbitrary PackageLocationString where+  arbitrary =+    PackageLocationString <$>+    oneof+      [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))+      , arbitraryGlobLikeStr+      , show <$> (arbitrary :: Gen URI)+      ]++arbitraryGlobLikeStr :: Gen String+arbitraryGlobLikeStr = outerTerm+  where+    outerTerm  = concat <$> shortListOf1 4+                  (frequency [ (2, token)+                             , (1, braces <$> innerTerm) ])+    innerTerm  = intercalate "," <$> shortListOf1 3+                  (frequency [ (3, token)+                             , (1, braces <$> innerTerm) ])+    token      = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))+    braces s   = "{" ++ s ++ "}"+++instance Arbitrary ProjectConfigBuildOnly where+    arbitrary =+      ProjectConfigBuildOnly+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (toNubList <$> shortListOf 2 arbitrary)             --  4+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)                  --  8+        <*> arbitrary+        <*> arbitraryNumJobs+        <*> arbitrary+        <*> arbitrary                                           -- 12+        <*> (fmap getShortToken <$> arbitrary)+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)                  -- 16+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)+      where+        arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary++    shrink (ProjectConfigBuildOnly+              x00 x01 x02 x03 x04 x05 x06 x07+              x08 x09 x10 x11 x12 x13 x14 x15+              x16 x17) =+      [ ProjectConfigBuildOnly+          x00' x01' x02' x03' x04'+          x05' x06' x07' x08' (postShrink_NumJobs x09')+          x10' x11' x12  x13' x14+          x15 x16 x17+      | ((x00', x01', x02', x03', x04'),+         (x05', x06', x07', x08', x09'),+         (x10', x11',       x13'))+          <- shrink+               ((x00, x01, x02, x03, x04),+                (x05, x06, x07, x08, preShrink_NumJobs x09),+                (x10, x11,      x13))+      ]+      where+        preShrink_NumJobs  = fmap (fmap Positive)+        postShrink_NumJobs = fmap (fmap getPositive)++instance Arbitrary ProjectConfigShared where+    arbitrary =+      ProjectConfigShared+        <$> arbitrary                                           --  4+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitraryConstraints+        <*> shortListOf 2 arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+      where+        arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]+        arbitraryConstraints =+            map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary++    shrink (ProjectConfigShared+              x00 x01 x02 x03 x04+              x05 x06 x07 x08 x09+              x10 x11 x12 x13) =+      [ ProjectConfigShared+          x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'+          x05' (postShrink_Constraints x06') x07' x08' x09'+          x10' x11' x12' x13'+      | ((x00', x01', x02', x03', x04'),+         (x05', x06', x07', x08', x09'),+         (x10', x11', x12', x13'))+          <- shrink+               ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),+                (x05, preShrink_Constraints x06, x07, x08, x09),+                (x10, x11, x12, x13))+      ]+      where+        preShrink_Constraints  = map fst+        postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))++projectConfigConstraintSource :: ConstraintSource+projectConfigConstraintSource = +    ConstraintSourceProjectConfig "TODO"++instance Arbitrary PackageConfig where+    arbitrary =+      PackageConfig+        <$> (MapLast . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> arbitraryShortToken))+        <*> (MapMappend . Map.fromList <$> shortListOf 10+              ((,) <$> arbitraryProgramName+                   <*> listOf arbitraryShortToken))+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+      where+        arbitraryProgramName :: Gen String+        arbitraryProgramName =+          elements [ programName prog+                   | (prog, _) <- knownPrograms (defaultProgramDb) ]++    shrink (PackageConfig+              x00 x01 x02 x03 x04+              x05 x06 x07 x08 x09+              x10 x11 x12 x13 x14+              x15 x16 x17 x18 x19+              x20 x21 x22 x23 x24+              x25 x26 x27 x28 x29+              x30 x31 x32 x33 x34+              x35 x36 x37 x38 x39+              x40) =+      [ PackageConfig+          (postShrink_Paths x00')+          (postShrink_Args  x01') x02' x03' x04'+          x05' x06' x07' x08' x09'+          x10' x11' (map getNonEmpty x12') x13' x14'+          x15' (map getNonEmpty x16')+               (map getNonEmpty x17')+               (map getNonEmpty x18')+                              x19'+          x20' x21' x22' x23' x24'+          x25' x26' x27' x28' x29'+          x30' x31' x32' x33' x34'+          x35' x36' (fmap getNonEmpty x37') x38'+                    (fmap getNonEmpty x39')+          x40'+      | (((x00', x01', x02', x03', x04'),+          (x05', x06', x07', x08', x09'),+          (x10', x11', x12', x13', x14'),+          (x15', x16', x17', x18', x19')),+         ((x20', x21', x22', x23', x24'),+          (x25', x26', x27', x28', x29'),+          (x30', x31', x32', x33', x34'),+          (x35', x36', x37', x38', x39'),+          (x40')))+          <- shrink+               (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),+                 (x05, x06, x07, x08, x09),+                 (x10, x11, map NonEmpty x12, x13, x14),+                 (x15, map NonEmpty x16,+                       map NonEmpty x17,+                       map NonEmpty x18,+                       x19)),+                ((x20, x21, x22, x23, x24),+                 (x25, x26, x27, x28, x29),+                 (x30, x31, x32, x33, x34),+                 (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39),+                 (x40)))+      ]+      where+        preShrink_Paths  = Map.map NonEmpty+                         . Map.mapKeys NoShrink+                         . getMapLast+        postShrink_Paths = MapLast+                         . Map.map getNonEmpty+                         . Map.mapKeys getNoShrink+        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)+                         . Map.mapKeys NoShrink+                         . getMapMappend+        postShrink_Args  = MapMappend+                         . Map.map (map getNonEmpty . getNonEmpty)+                         . Map.mapKeys getNoShrink+++instance Arbitrary SourceRepo where+    arbitrary = (SourceRepo RepoThis+                           <$> arbitrary+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary))+                `suchThat` (/= emptySourceRepo)++    shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =+      [ repo+      | ((x1', x2', x3'), (x4', x5', x6'))+          <- shrink ((x1,+                      fmap ShortToken x2,+                      fmap ShortToken x3),+                     (fmap ShortToken x4,+                      fmap ShortToken x5,+                      fmap ShortToken x6))+      , let repo = SourceRepo RepoThis x1'+                              (fmap getShortToken x2')+                              (fmap getShortToken x3')+                              (fmap getShortToken x4')+                              (fmap getShortToken x5')+                              (fmap getShortToken x6')+      , repo /= emptySourceRepo+      ]++emptySourceRepo :: SourceRepo+emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing+                                      Nothing Nothing Nothing+++instance Arbitrary RepoType where+    arbitrary = elements knownRepoTypes++instance Arbitrary ReportLevel where+    arbitrary = elements [NoReports .. DetailedReports]++instance Arbitrary CompilerFlavor where+    arbitrary = elements knownCompilerFlavors+      where+        --TODO: [code cleanup] export knownCompilerFlavors from D.Compiler+        -- it's already defined there, just need it exported.+        knownCompilerFlavors =+          [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]++instance Arbitrary a => Arbitrary (InstallDirs a) where+    arbitrary =+      InstallDirs+        <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  4+        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  8+        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12+        <*> arbitrary <*> arbitrary                             -- 14++instance Arbitrary PackageDB where+    arbitrary = oneof [ pure GlobalPackageDB+                      , pure UserPackageDB+                      , SpecificPackageDB . getShortToken <$> arbitrary+                      ]++instance Arbitrary RemoteRepo where+    arbitrary =+      RemoteRepo+        <$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`))+        <*> arbitrary  -- URI+        <*> arbitrary+        <*> listOf arbitraryRootKey+        <*> (fmap getNonNegative arbitrary)+        <*> pure False+      where+        arbitraryRootKey =+          shortListOf1 5 (oneof [ choose ('0', '9')+                                , choose ('a', 'f') ])++instance Arbitrary UserConstraint where+    arbitrary =+      oneof+        [ UserConstraintVersion   <$> arbitrary <*> arbitrary+        , UserConstraintInstalled <$> arbitrary+        , UserConstraintSource    <$> arbitrary+        , UserConstraintFlags     <$> arbitrary <*> shortListOf1 3 arbitrary+        , UserConstraintStanzas   <$> arbitrary <*> ((\x->[x]) <$> arbitrary)+        ]++instance Arbitrary OptionalStanza where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary FlagName where+    arbitrary = FlagName <$> flagident+      where+        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)+                      `suchThat` (("-" /=) . take 1)+        flagChars   = "-_" ++ ['a'..'z']++instance Arbitrary PreSolver where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary AllowNewer where+    arbitrary = oneof [ pure AllowNewerNone+                      , AllowNewerSome <$> shortListOf1 3 arbitrary+                      , pure AllowNewerAll+                      ]++instance Arbitrary AllowNewerDep where+    arbitrary = oneof [ AllowNewerDep       <$> arbitrary+                      , AllowNewerDepScoped <$> arbitrary <*> arbitrary+                      ]++instance Arbitrary ProfDetailLevel where+    arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]++instance Arbitrary OptimisationLevel where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary DebugInfoLevel where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary URI where+    arbitrary =+      URI <$> elements ["file:", "http:", "https:"]+          <*> (Just <$> arbitrary)+          <*> (('/':) <$> arbitraryURIToken)+          <*> (('?':) <$> arbitraryURIToken)+          <*> pure ""++instance Arbitrary URIAuth where+    arbitrary =+      URIAuth <$> pure ""   -- no password as this does not roundtrip+              <*> arbitraryURIToken+              <*> arbitraryURIPort++arbitraryURIToken :: Gen String+arbitraryURIToken =+    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))++arbitraryURIPort :: Gen String+arbitraryURIPort =+    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]+
tests/UnitTests/Distribution/Client/Sandbox.hs view
@@ -2,15 +2,14 @@   tests   ) where -import Distribution.Client.Sandbox    (withSandboxBinDirOnSearchPath)+import Distribution.Client.Sandbox (withSandboxBinDirOnSearchPath) -import Test.Framework                 as TF (Test)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit                     (Assertion, assertBool, assertEqual)+import Test.Tasty+import Test.Tasty.HUnit -import System.FilePath                (getSearchPath, (</>))+import System.FilePath             (getSearchPath, (</>)) -tests :: [TF.Test]+tests :: [TestTree] tests = [ testCase "sandboxBinDirOnSearchPath" sandboxBinDirOnSearchPathTest         , testCase "oldSearchPathRestored" oldSearchPathRestoreTest         ]
+ tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs view
@@ -0,0 +1,63 @@+module UnitTests.Distribution.Client.Sandbox.Timestamp (tests) where++import System.FilePath++import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity++import Distribution.Client.Compat.Time+import Distribution.Client.Sandbox.Timestamp++import Test.Tasty+import Test.Tasty.HUnit++tests :: [TestTree]+tests =+  [ testCase "timestamp record version 1 can be read" timestampReadTest_v1+  , testCase "timestamp record version 2 can be read" timestampReadTest_v2+  , testCase "written timestamp record can be read"   timestampReadWriteTest ]++timestampRecord_v1 :: String+timestampRecord_v1 =+  "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" +++  ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]\n"++timestampRecord_v2 :: String+timestampRecord_v2 =+  "2\n" +++  "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" +++  ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]"++timestampReadTest_v1 :: Assertion+timestampReadTest_v1 =+  timestampReadTest timestampRecord_v1 $+  map (\(i, ts) ->+        (i, map (\(p, ModTime t) ->+                  (p, posixSecondsToModTime . fromIntegral $ t)) ts))+  timestampRecord++timestampReadTest_v2 :: Assertion+timestampReadTest_v2 = timestampReadTest timestampRecord_v2 timestampRecord++timestampReadTest :: FilePath -> [TimestampFileRecord] -> Assertion+timestampReadTest fileContent expected =+  withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do+    let fileName = dir </> "timestamp-record"+    writeFile fileName fileContent+    tRec <- readTimestampFile fileName+    assertEqual "expected timestamp records to be equal"+      expected tRec++timestampRecord :: [TimestampFileRecord]+timestampRecord =+  [("i386-linux-ghc-8.0.0.20160204",[("/foo/bar/Baz",ModTime 1455350946)])+  ,("i386-linux-ghc-7.10.3",[("/foo/bar/Baz",ModTime 1455484719)])]++timestampReadWriteTest :: Assertion+timestampReadWriteTest =+  withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do+    let fileName = dir </> "timestamp-record"+    writeTimestampFile fileName timestampRecord+    tRec <- readTimestampFile fileName+    assertEqual "expected timestamp records to be equal"+      timestampRecord tRec
+ tests/UnitTests/Distribution/Client/Tar.hs view
@@ -0,0 +1,75 @@+module UnitTests.Distribution.Client.Tar (+  tests+  ) where++import Distribution.Client.Tar ( filterEntries+                               , filterEntriesM+                               )+import Codec.Archive.Tar       ( Entries(..)+                               , foldEntries+                               )+import Codec.Archive.Tar.Entry ( EntryContent(..)+                               , simpleEntry+                               , Entry(..)+                               , toTarPath+                               )++import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Control.Monad.Writer.Lazy (runWriterT, tell)++tests :: [TestTree]+tests = [ testCase "filterEntries" filterTest+        , testCase "filterEntriesM" filterMTest+        ]++filterTest :: Assertion+filterTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let (NormalFile dta _) = entryContent e+                     str = BS.Char8.unpack dta+                 in not . (=="y") $ str)+  assertEqual "Unexpected result for filter" "xz" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filter" "z" $+    entriesToString $ filterEntries p $ Done+  assertEqual "Unexpected result for filter" "xf" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f"++filterMTest :: Assertion+filterMTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let (NormalFile dta _) = entryContent e+                     str = BS.Char8.unpack dta+                 in tell "t" >> return (not . (=="y") $ str))++  (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filterM" "xz" $ entriesToString r+  assertEqual "Unexpected result for filterM w" "tt" w++  (r1, w1) <- runWriterT $ filterEntriesM p $ Done+  assertEqual "Unexpected result for filterM" "z" $ entriesToString r1+  assertEqual "Unexpected result for filterM w" "" w1++  (r2, w2) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 $ Fail "f"+  assertEqual "Unexpected result for filterM" "xf" $ entriesToString r2+  assertEqual "Unexpected result for filterM w" "tt" w2++getFileEntry :: FilePath -> [Char] -> Entry+getFileEntry pth dta =+  simpleEntry tp $ NormalFile dta' $ BS.length dta'+  where  tp = case toTarPath False pth of+           Right tp' -> tp'+           Left e -> error e+         dta' = BS.Char8.pack dta++entriesToString :: Entries String -> String+entriesToString =+  foldEntries (\e acc -> let (NormalFile dta _) = entryContent e+                             str = BS.Char8.unpack dta+                          in str ++ acc) "z" id
tests/UnitTests/Distribution/Client/Targets.hs view
@@ -8,13 +8,12 @@ import Distribution.ParseUtils         (parseCommaList) import Distribution.Text               (parse) -import Test.Framework                  as TF (Test)-import Test.Framework.Providers.HUnit  (testCase)-import Test.HUnit                      (Assertion, assertEqual)+import Test.Tasty+import Test.Tasty.HUnit  import Data.Char                       (isSpace) -tests :: [TF.Test]+tests :: [TestTree] tests = [ testCase "readUserConstraint" readUserConstraintTest         , testCase "parseUserConstraint" parseUserConstraintTest         , testCase "readUserConstraints" readUserConstraintsTest
tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -4,74 +4,73 @@     ) where  import Control.Exception (bracket)+import Control.Monad (replicateM_) import Data.List (sort, nub) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif-import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing)-import System.FilePath (takeDirectory)+import System.Directory (doesFileExist,+                         getCurrentDirectory, getTemporaryDirectory)+import System.FilePath ((</>)) -import Test.Framework as TF (Test)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertBool)+import Test.Tasty+import Test.Tasty.HUnit -import Distribution.Client.Compat.Environment (lookupEnv, setEnv) import Distribution.Client.Config import Distribution.Utils.NubList (fromNubList) import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))-import Distribution.Simple.Setup (ConfigFlags (..), fromFlag)+import Distribution.Client.Utils (removeExistingFile)+import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag)+import Distribution.Simple.Utils (withTempDirectory) import Distribution.Verbosity (silent) -tests :: [TF.Test]+tests :: [TestTree] tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest         , testCase "canDetectDifference" canDetectDifference         , testCase "canUpdateConfig" canUpdateConfig         , testCase "doubleUpdateConfig" doubleUpdateConfig+        , testCase "newDefaultConfig" newDefaultConfig         ]  nullDiffOnCreateTest :: Assertion-nullDiffOnCreateTest = bracketTest . const $ do+nullDiffOnCreateTest = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty mempty+    _ <- loadConfig silent (Flag configFile)     -- Now we read it in and compare it against the default.-    diff <- userConfigDiff mempty+    diff <- userConfigDiff $ globalFlags configFile     assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff   canDetectDifference :: Assertion-canDetectDifference = bracketTest . const $ do+canDetectDifference = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty mempty-    cabalFile <- defaultConfigFile-    appendFile cabalFile "verbose: 0\n"-    diff <- userConfigDiff mempty+    _ <- loadConfig silent (Flag configFile)+    appendFile configFile "verbose: 0\n"+    diff <- userConfigDiff $ globalFlags configFile     assertBool (unlines $ "Should detect a difference:" : diff) $         diff == [ "- verbose: 1", "+ verbose: 0" ]   canUpdateConfig :: Assertion-canUpdateConfig = bracketTest . const $ do-    cabalFile <- defaultConfigFile-    createDirectoryIfMissing True $ takeDirectory cabalFile+canUpdateConfig = bracketTest $ \configFile -> do     -- Write a trivial cabal file.-    writeFile cabalFile "tests: True\n"+    writeFile configFile "tests: True\n"     -- Update the config file.-    userConfigUpdate silent mempty+    userConfigUpdate silent $ globalFlags configFile     -- Load it again.-    updated <- loadConfig silent mempty mempty+    updated <- loadConfig silent (Flag configFile)     assertBool ("Field 'tests' should be True") $         fromFlag (configTests $ savedConfigureFlags updated)   doubleUpdateConfig :: Assertion-doubleUpdateConfig = bracketTest . const $ do+doubleUpdateConfig = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty mempty-    -- Update it.-    userConfigUpdate silent mempty-    userConfigUpdate silent mempty+    _ <- loadConfig silent (Flag configFile)+    -- Update it twice.+    replicateM_ 2 . userConfigUpdate silent $ globalFlags configFile     -- Load it again.-    updated <- loadConfig silent mempty mempty+    updated <- loadConfig silent (Flag configFile)      assertBool ("Field 'remote-repo' doesn't contain duplicates") $         listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)@@ -81,24 +80,33 @@         listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)  +newDefaultConfig :: Assertion+newDefaultConfig = do+    sysTmpDir <- getTemporaryDirectory+    withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do+        let configFile  = tmpDir </> "tmp.config"+        createDefaultConfigFile silent configFile+        exists <- doesFileExist configFile+        assertBool ("Config file should be written to " ++ configFile) exists+++globalFlags :: FilePath -> GlobalFlags+globalFlags configFile = mempty { globalConfigFile = Flag configFile }++ listUnique :: Ord a => [a] -> Bool listUnique xs =     let sorted = sort xs     in nub sorted == xs  -bracketTest :: ((FilePath, FilePath) -> IO ()) -> Assertion+bracketTest :: (FilePath -> IO ()) -> Assertion bracketTest =     bracket testSetup testTearDown   where-    testSetup :: IO (FilePath, FilePath)-    testSetup = do-        Just oldHome <- lookupEnv "HOME"-        testdir <- fmap (++ "/test-user-config") getCurrentDirectory-        setEnv "HOME" testdir-        return (oldHome, testdir)+    testSetup :: IO FilePath+    testSetup = fmap (</> "test-user-config") getCurrentDirectory -    testTearDown :: (FilePath, FilePath) -> IO ()-    testTearDown (oldHome, testdir) = do-        setEnv "HOME" oldHome-        removeDirectoryRecursive testdir+    testTearDown :: FilePath -> IO ()+    testTearDown configFile =+        mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
+ tests/UnitTests/Options.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}++module UnitTests.Options ( OptionShowSolverLog(..)+                         , OptionMtimeChangeDelay(..)+                         , extraOptions )+       where++import Data.Proxy+import Data.Typeable++import Test.Tasty.Options++{-------------------------------------------------------------------------------+  Test options+-------------------------------------------------------------------------------}++extraOptions :: [OptionDescription]+extraOptions =+  [ Option (Proxy :: Proxy OptionShowSolverLog)+  , Option (Proxy :: Proxy OptionMtimeChangeDelay)+  ]++newtype OptionShowSolverLog = OptionShowSolverLog Bool+  deriving Typeable++instance IsOption OptionShowSolverLog where+  defaultValue   = OptionShowSolverLog False+  parseValue     = fmap OptionShowSolverLog . safeRead+  optionName     = return "show-solver-log"+  optionHelp     = return "Show full log from the solver"+  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)++newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int+  deriving Typeable++instance IsOption OptionMtimeChangeDelay where+  defaultValue   = OptionMtimeChangeDelay 0+  parseValue     = fmap OptionMtimeChangeDelay . safeRead+  optionName     = return "mtime-change-delay"+  optionHelp     = return $ "How long to wait before attempting to detect"+                   ++ "file modification, in microseconds"