diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs
--- a/Distribution/Client/BuildReports/Anonymous.hs
+++ b/Distribution/Client/BuildReports/Anonymous.hs
@@ -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
diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs
--- a/Distribution/Client/BuildReports/Storage.hs
+++ b/Distribution/Client/BuildReports/Storage.hs
@@ -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
diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs
--- a/Distribution/Client/BuildReports/Types.hs
+++ b/Distribution/Client/BuildReports/Types.hs
@@ -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"
diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs
--- a/Distribution/Client/BuildReports/Upload.hs
+++ b/Distribution/Client/BuildReports/Upload.hs
@@ -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
diff --git a/Distribution/Client/BuildTarget.hs b/Distribution/Client/BuildTarget.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/BuildTarget.hs
@@ -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"
+-}
+
diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs
--- a/Distribution/Client/Check.hs
+++ b/Distribution/Client/Check.hs
@@ -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)
diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/CmdBuild.hs
@@ -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
+
diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/CmdConfigure.hs
@@ -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)
+
diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/CmdRepl.hs
@@ -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
+
diff --git a/Distribution/Client/Compat/Environment.hs b/Distribution/Client/Compat/Environment.hs
deleted file mode 100644
--- a/Distribution/Client/Compat/Environment.hs
+++ /dev/null
@@ -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 */
diff --git a/Distribution/Client/Compat/Time.hs b/Distribution/Client/Compat/Time.hs
--- a/Distribution/Client/Compat/Time.hs
+++ b/Distribution/Client/Compat/Time.hs
@@ -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'.
diff --git a/Distribution/Client/ComponentDeps.hs b/Distribution/Client/ComponentDeps.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ComponentDeps.hs
@@ -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
diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs
--- a/Distribution/Client/Config.hs
+++ b/Distribution/Client/Config.hs
@@ -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
diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs
--- a/Distribution/Client/Configure.hs
+++ b/Distribution/Client/Configure.hs
@@ -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,
diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs
--- a/Distribution/Client/Dependency.hs
+++ b/Distribution/Client/Dependency.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs
--- a/Distribution/Client/Dependency/Modular.hs
+++ b/Distribution/Client/Dependency/Modular.hs
@@ -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.
diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs
--- a/Distribution/Client/Dependency/Modular/Assignment.hs
+++ b/Distribution/Client/Dependency/Modular/Assignment.hs
@@ -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))
diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs
--- a/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/Distribution/Client/Dependency/Modular/Builder.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Configured.hs b/Distribution/Client/Dependency/Modular/Configured.hs
--- a/Distribution/Client/Dependency/Modular/Configured.hs
+++ b/Distribution/Client/Dependency/Modular/Configured.hs
@@ -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])
diff --git a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
--- a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
+++ b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/ConflictSet.hs b/Distribution/Client/Dependency/Modular/ConflictSet.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Dependency/Modular/ConflictSet.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Cycles.hs b/Distribution/Client/Dependency/Modular/Cycles.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Dependency/Modular/Cycles.hs
@@ -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)
diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs
--- a/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs
--- a/Distribution/Client/Dependency/Modular/Explore.hs
+++ b/Distribution/Client/Dependency/Modular/Explore.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs
--- a/Distribution/Client/Dependency/Modular/Flag.hs
+++ b/Distribution/Client/Dependency/Modular/Flag.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs
--- a/Distribution/Client/Dependency/Modular/Index.hs
+++ b/Distribution/Client/Dependency/Modular/Index.hs
@@ -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"
diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs
--- a/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -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)
diff --git a/Distribution/Client/Dependency/Modular/Linking.hs b/Distribution/Client/Dependency/Modular/Linking.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Dependency/Modular/Linking.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs
--- a/Distribution/Client/Dependency/Modular/Log.hs
+++ b/Distribution/Client/Dependency/Modular/Log.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs
--- a/Distribution/Client/Dependency/Modular/Message.hs
+++ b/Distribution/Client/Dependency/Modular/Message.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs
--- a/Distribution/Client/Dependency/Modular/PSQ.hs
+++ b/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -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)
diff --git a/Distribution/Client/Dependency/Modular/Package.hs b/Distribution/Client/Dependency/Modular/Package.hs
--- a/Distribution/Client/Dependency/Modular/Package.hs
+++ b/Distribution/Client/Dependency/Modular/Package.hs
@@ -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
+ ]
diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs
--- a/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/Distribution/Client/Dependency/Modular/Preference.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs
--- a/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/Distribution/Client/Dependency/Modular/Solver.hs
@@ -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
diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs
--- a/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/Distribution/Client/Dependency/Modular/Tree.hs
@@ -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 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
diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs
--- a/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/Distribution/Client/Dependency/Modular/Validate.hs
@@ -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
+ }
diff --git a/Distribution/Client/Dependency/Modular/Var.hs b/Distribution/Client/Dependency/Modular/Var.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Dependency/Modular/Var.hs
@@ -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)
diff --git a/Distribution/Client/Dependency/Modular/Version.hs b/Distribution/Client/Dependency/Modular/Version.hs
--- a/Distribution/Client/Dependency/Modular/Version.hs
+++ b/Distribution/Client/Dependency/Modular/Version.hs
@@ -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 []
diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs
--- a/Distribution/Client/Dependency/TopDown.hs
+++ b/Distribution/Client/Dependency/TopDown.hs
@@ -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
diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs
--- a/Distribution/Client/Dependency/TopDown/Constraints.hs
+++ b/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -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
diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs
--- a/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/Distribution/Client/Dependency/TopDown/Types.hs
@@ -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
+
diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs
--- a/Distribution/Client/Dependency/Types.hs
+++ b/Distribution/Client/Dependency/Types.hs
@@ -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"
diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/DistDirLayout.hs
@@ -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"
+
diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs
--- a/Distribution/Client/Exec.hs
+++ b/Distribution/Client/Exec.hs
@@ -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
diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs
--- a/Distribution/Client/Fetch.hs
+++ b/Distribution/Client/Fetch.hs
@@ -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 ()
diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs
--- a/Distribution/Client/FetchUtils.hs
+++ b/Distribution/Client/FetchUtils.hs
@@ -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
-- ------------------------------------------------------------
diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/FileMonitor.hs
@@ -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"
diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs
--- a/Distribution/Client/Freeze.hs
+++ b/Distribution/Client/Freeze.hs
@@ -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
diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/GenBounds.hs
@@ -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."
+ , ""
+ ]
diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs
--- a/Distribution/Client/Get.hs
+++ b/Distribution/Client/Get.hs
@@ -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
diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Glob.hs
@@ -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
diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/GlobalFlags.hs
@@ -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
diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs
--- a/Distribution/Client/Haddock.hs
+++ b/Distribution/Client/Haddock.hs
@@ -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
diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs
--- a/Distribution/Client/HttpUtils.hs
+++ b/Distribution/Client/HttpUtils.hs
@@ -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
diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs
--- a/Distribution/Client/IndexUtils.hs
+++ b/Distribution/Client/IndexUtils.hs
@@ -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
diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs
--- a/Distribution/Client/Init.hs
+++ b/Distribution/Client/Init.hs
@@ -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
diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs
--- a/Distribution/Client/Init/Heuristics.hs
+++ b/Distribution/Client/Init/Heuristics.hs
@@ -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]
diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs
--- a/Distribution/Client/Init/Types.hs
+++ b/Distribution/Client/Init/Types.hs
@@ -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
diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs
--- a/Distribution/Client/Install.hs
+++ b/Distribution/Client/Install.hs
@@ -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
diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs
--- a/Distribution/Client/InstallPlan.hs
+++ b/Distribution/Client/InstallPlan.hs
@@ -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
diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs
--- a/Distribution/Client/InstallSymlink.hs
+++ b/Distribution/Client/InstallSymlink.hs
@@ -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
diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs
--- a/Distribution/Client/List.hs
+++ b/Distribution/Client/List.hs
@@ -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
diff --git a/Distribution/Client/Manpage.hs b/Distribution/Client/Manpage.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Manpage.hs
@@ -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"
+ , ""
+ ]
diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/PackageHash.hs
@@ -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"
+
diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs
--- a/Distribution/Client/PackageIndex.hs
+++ b/Distribution/Client/PackageIndex.hs
@@ -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
diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs
--- a/Distribution/Client/ParseUtils.hs
+++ b/Distribution/Client/ParseUtils.hs
@@ -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
+
diff --git a/Distribution/Client/PkgConfigDb.hs b/Distribution/Client/PkgConfigDb.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/PkgConfigDb.hs
@@ -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 []
+
diff --git a/Distribution/Client/PlanIndex.hs b/Distribution/Client/PlanIndex.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/PlanIndex.hs
@@ -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)
+ )
diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectBuilding.hs
@@ -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
+
diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectConfig.hs
@@ -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)
+
diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectConfig/Legacy.hs
@@ -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 = (++)
diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectConfig/Types.hs
@@ -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
+ }
+
diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectOrchestration.hs
@@ -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?
+
diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectPlanOutput.hs
@@ -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
+
diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectPlanning.hs
@@ -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)
diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/ProjectPlanning/Types.hs
@@ -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
+
diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/RebuildMonad.hs
@@ -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
+
diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs
--- a/Distribution/Client/Run.hs
+++ b/Distribution/Client/Run.hs
@@ -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 ()
diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs
--- a/Distribution/Client/Sandbox.hs
+++ b/Distribution/Client/Sandbox.hs
@@ -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
+ )
diff --git a/Distribution/Client/Sandbox/Index.hs b/Distribution/Client/Sandbox/Index.hs
--- a/Distribution/Client/Sandbox/Index.hs
+++ b/Distribution/Client/Sandbox/Index.hs
@@ -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.
diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs
--- a/Distribution/Client/Sandbox/PackageEnvironment.hs
+++ b/Distribution/Client/Sandbox/PackageEnvironment.hs
@@ -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)
diff --git a/Distribution/Client/Sandbox/Timestamp.hs b/Distribution/Client/Sandbox/Timestamp.hs
--- a/Distribution/Client/Sandbox/Timestamp.hs
+++ b/Distribution/Client/Sandbox/Timestamp.hs
@@ -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
diff --git a/Distribution/Client/Sandbox/Types.hs b/Distribution/Client/Sandbox/Types.hs
--- a/Distribution/Client/Sandbox/Types.hs
+++ b/Distribution/Client/Sandbox/Types.hs
@@ -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@.
diff --git a/Distribution/Client/Security/HTTP.hs b/Distribution/Client/Security/HTTP.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Security/HTTP.hs
@@ -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
+ 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)
diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs
--- a/Distribution/Client/Setup.hs
+++ b/Distribution/Client/Setup.hs
@@ -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
diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs
--- a/Distribution/Client/SetupWrapper.hs
+++ b/Distribution/Client/SetupWrapper.hs
@@ -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
diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs
--- a/Distribution/Client/SrcDist.hs
+++ b/Distribution/Client/SrcDist.hs
@@ -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
diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs
--- a/Distribution/Client/Tar.hs
+++ b/Distribution/Client/Tar.hs
@@ -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
diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs
--- a/Distribution/Client/Targets.hs
+++ b/Distribution/Client/Targets.hs
@@ -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
+
diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs
--- a/Distribution/Client/Types.hs
+++ b/Distribution/Client/Types.hs
@@ -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"
diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs
--- a/Distribution/Client/Update.hs
+++ b/Distribution/Client/Update.hs
@@ -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)
diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs
--- a/Distribution/Client/Upload.hs
+++ b/Distribution/Client/Upload.hs
@@ -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 -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
diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs
--- a/Distribution/Client/Utils.hs
+++ b/Distribution/Client/Utils.hs
@@ -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"
diff --git a/Distribution/Client/Utils/Json.hs b/Distribution/Client/Utils/Json.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Utils/Json.hs
@@ -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` ['\\','"']
diff --git a/Distribution/Client/Utils/LabeledGraph.hs b/Distribution/Client/Utils/LabeledGraph.hs
new file mode 100644
--- /dev/null
+++ b/Distribution/Client/Utils/LabeledGraph.hs
@@ -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
diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -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
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -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")]
diff --git a/bash-completion/cabal b/bash-completion/cabal
--- a/bash-completion/cabal
+++ b/bash-completion/cabal
@@ -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]}
diff --git a/bootstrap.sh b/bootstrap.sh
--- a/bootstrap.sh
+++ b/bootstrap.sh
@@ -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"
diff --git a/cabal-install.cabal b/cabal-install.cabal
--- a/cabal-install.cabal
+++ b/cabal-install.cabal
@@ -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
2007-2012 Duncan Coutts
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
diff --git a/cbits/getnumcores.c b/cbits/getnumcores.c
--- a/cbits/getnumcores.c
+++ b/cbits/getnumcores.c
@@ -8,7 +8,7 @@
#ifndef HAS_GET_NUMBER_OF_PROCESSORS
-#ifdef _WIN32
+#if defined(_WIN32) && !defined(__CYGWIN__)
#include
#elif MACOS
#include
@@ -18,7 +18,7 @@
#endif
int getNumberOfProcessors() {
-#ifdef WIN32
+#if defined(_WIN32) && !defined(__CYGWIN__)
SYSTEM_INFO sysinfo;
GetSystemInfo(&sysinfo);
return sysinfo.dwNumberOfProcessors;
diff --git a/changelog b/changelog
--- a/changelog
+++ b/changelog
@@ -1,38 +1,65 @@
-*-change-log-*-
-1.22.9.0 Ryan Thomas March 2016
- * Include Cabal-1.22.8.0
-1.22.8.0 Ryan Thomas 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 June 2015
- * A fix for @ezyang's fix for #2502. (Mikhail Glushenkov)
-
-1.22.5.0 Ryan Thomas June 2015
- * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang)
-
-1.22.4.0 Ryan Thomas 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 April 2015
- * Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov)
- * filterConfigureFlags: filter more flags (Mikhail Glushenkov)
-
-1.22.2.0 Ryan Thomas 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 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 January 2015
* New command: user-config (#2159).
* Implement 'cabal repl --only' (#2016).
* Fix an issue when 'cabal repl' was doing unnecessary compilation
diff --git a/tests/IntegrationTests.hs b/tests/IntegrationTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests.hs
@@ -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 = " was:\n" ++ C8.unpack (trStdOut testResult)
+ 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
diff --git a/tests/IntegrationTests/custom/common.sh b/tests/IntegrationTests/custom/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/custom/should_run/plain.err b/tests/IntegrationTests/custom/should_run/plain.err
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/should_run/plain.err
@@ -0,0 +1,2 @@
+Custom
+Custom
diff --git a/tests/IntegrationTests/custom/should_run/plain.sh b/tests/IntegrationTests/custom/should_run/plain.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/should_run/plain.sh
@@ -0,0 +1,4 @@
+. ../common.sh
+cd plain
+cabal configure
+cabal build
diff --git a/tests/IntegrationTests/custom/should_run/plain/A.hs b/tests/IntegrationTests/custom/should_run/plain/A.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/should_run/plain/A.hs
@@ -0,0 +1,1 @@
+module A where
diff --git a/tests/IntegrationTests/custom/should_run/plain/Setup.hs b/tests/IntegrationTests/custom/should_run/plain/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/should_run/plain/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+import System.IO
+main = hPutStrLn stderr "Custom" >> defaultMain
diff --git a/tests/IntegrationTests/custom/should_run/plain/plain.cabal b/tests/IntegrationTests/custom/should_run/plain/plain.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/custom/should_run/plain/plain.cabal
@@ -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
diff --git a/tests/IntegrationTests/exec/common.sh b/tests/IntegrationTests/exec/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err b/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err
@@ -0,0 +1,1 @@
+RE:^cabal(\.exe)?: Please specify an executable to run$
diff --git a/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh b/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+
+cabal exec
diff --git a/tests/IntegrationTests/exec/should_run/Foo.hs b/tests/IntegrationTests/exec/should_run/Foo.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/Foo.hs
@@ -0,0 +1,4 @@
+module Foo where
+
+foo :: String
+foo = "foo"
diff --git a/tests/IntegrationTests/exec/should_run/My.hs b/tests/IntegrationTests/exec/should_run/My.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/My.hs
@@ -0,0 +1,5 @@
+module Main where
+
+main :: IO ()
+main = do
+ putStrLn "This is my-executable"
diff --git a/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out b/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out
@@ -0,0 +1,1 @@
+This is my-executable
diff --git a/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh b/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh
@@ -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"
diff --git a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out
@@ -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
diff --git a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh
@@ -0,0 +1,2 @@
+. ../common.sh
+cabal exec echo find_me_in_output
diff --git a/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out b/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out
@@ -0,0 +1,1 @@
+This is my-executable
diff --git a/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh b/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh
@@ -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"
diff --git a/tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh b/tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh
@@ -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"
diff --git a/tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh b/tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh
@@ -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"
diff --git a/tests/IntegrationTests/exec/should_run/my.cabal b/tests/IntegrationTests/exec/should_run/my.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/my.cabal
@@ -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
diff --git a/tests/IntegrationTests/exec/should_run/runs_given_command.out b/tests/IntegrationTests/exec/should_run/runs_given_command.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/runs_given_command.out
@@ -0,0 +1,1 @@
+this string
diff --git a/tests/IntegrationTests/exec/should_run/runs_given_command.sh b/tests/IntegrationTests/exec/should_run/runs_given_command.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/exec/should_run/runs_given_command.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal configure > /dev/null
+cabal exec echo this string
diff --git a/tests/IntegrationTests/freeze/common.sh b/tests/IntegrationTests/freeze/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh b/tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze --disable-benchmarks
+grep -v " criterion ==" cabal.config || die "should NOT have frozen criterion"
diff --git a/tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh b/tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze --disable-tests
+grep -v " test-framework ==" cabal.config || die "should NOT have frozen test-framework"
diff --git a/tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh b/tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh
@@ -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"
diff --git a/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh b/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze
+grep -v " my ==" cabal.config || die "should not have frozen self"
diff --git a/tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh b/tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze --dry-run
+[ ! -e cabal.config ] || die "cabal.config file should not have been created"
diff --git a/tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh b/tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh
@@ -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"
diff --git a/tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh b/tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze --enable-tests
+grep " test-framework ==" cabal.config || die "should have frozen test-framework"
diff --git a/tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh b/tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze
+grep " base ==" cabal.config || die "'base' should have been frozen"
diff --git a/tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh b/tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh
@@ -0,0 +1,3 @@
+. ../common.sh
+cabal freeze
+grep " ghc-prim ==" cabal.config || die "'ghc-prim' should have been frozen"
diff --git a/tests/IntegrationTests/freeze/should_run/my.cabal b/tests/IntegrationTests/freeze/should_run/my.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/my.cabal
@@ -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
diff --git a/tests/IntegrationTests/freeze/should_run/runs_without_error.sh b/tests/IntegrationTests/freeze/should_run/runs_without_error.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/freeze/should_run/runs_without_error.sh
@@ -0,0 +1,2 @@
+. ../common.sh
+cabal freeze
diff --git a/tests/IntegrationTests/manpage/common.sh b/tests/IntegrationTests/manpage/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/manpage/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/manpage/should_run/outputs_manpage.sh b/tests/IntegrationTests/manpage/should_run/outputs_manpage.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/manpage/should_run/outputs_manpage.sh
@@ -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
diff --git a/tests/IntegrationTests/multiple-source/common.sh b/tests/IntegrationTests/multiple-source/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/common.sh
@@ -0,0 +1,8 @@
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh b/tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh
@@ -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
diff --git a/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs b/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/multiple-source/should_run/p/p.cabal b/tests/IntegrationTests/multiple-source/should_run/p/p.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/should_run/p/p.cabal
@@ -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
diff --git a/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs b/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/multiple-source/should_run/q/q.cabal b/tests/IntegrationTests/multiple-source/should_run/q/q.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/multiple-source/should_run/q/q.cabal
@@ -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
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files.sh b/tests/IntegrationTests/new-build/monitor_cabal_files.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files.sh
@@ -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
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs
@@ -0,0 +1,1 @@
+module P where
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal b/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal
@@ -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
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs
@@ -0,0 +1,4 @@
+module Main where
+import P
+main :: IO ()
+main = return ()
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in b/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in
@@ -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
diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in b/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in
@@ -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
diff --git a/tests/IntegrationTests/regression/common.sh b/tests/IntegrationTests/regression/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/regression/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/regression/t3199.sh b/tests/IntegrationTests/regression/t3199.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/regression/t3199.sh
@@ -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
diff --git a/tests/IntegrationTests/regression/t3199/Main.hs b/tests/IntegrationTests/regression/t3199/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/regression/t3199/Main.hs
@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "Hello, Haskell!"
diff --git a/tests/IntegrationTests/regression/t3199/Setup.hs b/tests/IntegrationTests/regression/t3199/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/regression/t3199/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/regression/t3199/test-3199.cabal b/tests/IntegrationTests/regression/t3199/test-3199.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/regression/t3199/test-3199.cabal
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/common.sh b/tests/IntegrationTests/sandbox-sources/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/common.sh
@@ -0,0 +1,8 @@
+cabal() {
+ "$CABAL" $CABAL_ARGS "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err b/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err
@@ -0,0 +1,3 @@
+Warning: Sources not registered: "q"
+
+RE:^cabal(\.exe)?: The sources with the above errors were skipped\. \("q"\)$
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh b/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal b/tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal b/tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal b/tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal b/tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh b/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh
@@ -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
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out b/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out
@@ -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.
diff --git a/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh b/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh
@@ -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
diff --git a/tests/IntegrationTests/user-config/common.sh b/tests/IntegrationTests/user-config/common.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/common.sh
@@ -0,0 +1,9 @@
+# Helper to run Cabal
+cabal() {
+ "$CABAL" $CABAL_ARGS_NO_CONFIG_FILE "$@"
+}
+
+die() {
+ echo "die: $@"
+ exit 1
+}
diff --git a/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err b/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err
@@ -0,0 +1,1 @@
+RE:^cabal(\.exe)?: \./cabal-config already exists\.$
diff --git a/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh b/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh
@@ -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
diff --git a/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out b/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out
@@ -0,0 +1,2 @@
+Writing default configuration to ./cabal-config
+Writing default configuration to ./cabal-config
diff --git a/tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh b/tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh
@@ -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
diff --git a/tests/IntegrationTests/user-config/should_run/runs_without_error.out b/tests/IntegrationTests/user-config/should_run/runs_without_error.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/runs_without_error.out
@@ -0,0 +1,1 @@
+Writing default configuration to ./cabal-config
diff --git a/tests/IntegrationTests/user-config/should_run/runs_without_error.sh b/tests/IntegrationTests/user-config/should_run/runs_without_error.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/runs_without_error.sh
@@ -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
diff --git a/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out b/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out
@@ -0,0 +1,1 @@
+Writing default configuration to ./my-config
diff --git a/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh b/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh
new file mode 100644
--- /dev/null
+++ b/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh
@@ -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"
diff --git a/tests/PackageTests.hs b/tests/PackageTests.hs
deleted file mode 100644
--- a/tests/PackageTests.hs
+++ /dev/null
@@ -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
diff --git a/tests/PackageTests/Exec/Check.hs b/tests/PackageTests/Exec/Check.hs
deleted file mode 100644
--- a/tests/PackageTests/Exec/Check.hs
+++ /dev/null
@@ -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)
diff --git a/tests/PackageTests/Freeze/Check.hs b/tests/PackageTests/Freeze/Check.hs
deleted file mode 100644
--- a/tests/PackageTests/Freeze/Check.hs
+++ /dev/null
@@ -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"
diff --git a/tests/PackageTests/Freeze/my.cabal b/tests/PackageTests/Freeze/my.cabal
deleted file mode 100644
--- a/tests/PackageTests/Freeze/my.cabal
+++ /dev/null
@@ -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
diff --git a/tests/PackageTests/MultipleSource/Check.hs b/tests/PackageTests/MultipleSource/Check.hs
deleted file mode 100644
--- a/tests/PackageTests/MultipleSource/Check.hs
+++ /dev/null
@@ -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"]
- ]
diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs
deleted file mode 100644
--- a/tests/PackageTests/PackageTester.hs
+++ /dev/null
@@ -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"
diff --git a/tests/README.md b/tests/README.md
new file mode 100644
--- /dev/null
+++ b/tests/README.md
@@ -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
diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs
--- a/tests/UnitTests.hs
+++ b/tests/UnitTests.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
@@ -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 _ = []
+
diff --git a/tests/UnitTests/Distribution/Client/Compat/Time.hs b/tests/UnitTests/Distribution/Client/Compat/Time.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Compat/Time.hs
@@ -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)
diff --git a/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
@@ -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 "<>"
+ , 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)
diff --git a/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs b/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs
--- a/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs
+++ b/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -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
]
diff --git a/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
@@ -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"]
+ ]
diff --git a/tests/UnitTests/Distribution/Client/FileMonitor.hs b/tests/UnitTests/Distribution/Client/FileMonitor.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/FileMonitor.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/GZipUtils.hs b/tests/UnitTests/Distribution/Client/GZipUtils.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/GZipUtils.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/Glob.hs b/tests/UnitTests/Distribution/Client/Glob.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Glob.hs
@@ -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'] \\ "*{},/\\"
+
diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -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')) ]
+
diff --git a/tests/UnitTests/Distribution/Client/Sandbox.hs b/tests/UnitTests/Distribution/Client/Sandbox.hs
--- a/tests/UnitTests/Distribution/Client/Sandbox.hs
+++ b/tests/UnitTests/Distribution/Client/Sandbox.hs
@@ -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
]
diff --git a/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs b/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/Tar.hs b/tests/UnitTests/Distribution/Client/Tar.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Distribution/Client/Tar.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/Targets.hs b/tests/UnitTests/Distribution/Client/Targets.hs
--- a/tests/UnitTests/Distribution/Client/Targets.hs
+++ b/tests/UnitTests/Distribution/Client/Targets.hs
@@ -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
diff --git a/tests/UnitTests/Distribution/Client/UserConfig.hs b/tests/UnitTests/Distribution/Client/UserConfig.hs
--- a/tests/UnitTests/Distribution/Client/UserConfig.hs
+++ b/tests/UnitTests/Distribution/Client/UserConfig.hs
@@ -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"]
diff --git a/tests/UnitTests/Options.hs b/tests/UnitTests/Options.hs
new file mode 100644
--- /dev/null
+++ b/tests/UnitTests/Options.hs
@@ -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"