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 @@ -27,18 +27,18 @@ ) where import qualified Distribution.Client.Types as BR - ( BuildResult, BuildFailure(..), BuildSuccess(..) + ( BuildOutcome, BuildFailure(..), BuildResult(..) , DocsResult(..), TestsResult(..) ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import qualified Paths_cabal_install (version) import Distribution.Package - ( PackageIdentifier(..), PackageName(..) ) + ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) ---import Distribution.Version --- ( Version ) + ( FlagName, mkFlagName, unFlagName, FlagAssignment ) +import Distribution.Version + ( mkVersion' ) import Distribution.System ( OS, Arch ) import Distribution.Compiler @@ -120,7 +120,7 @@ deriving Eq new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment - -> [PackageIdentifier] -> BR.BuildResult -> BuildReport + -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport new os' arch' comp pkgid flags deps result = BuildReport { package = pkgid, @@ -145,21 +145,22 @@ Left (BR.BuildFailed _) -> BuildFailed Left (BR.TestsFailed _) -> TestsFailed Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk + Right (BR.BuildResult _ _ _) -> InstallOk convertDocsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildOk BR.DocsNotTried _ _) -> NotTried - Right (BR.BuildOk BR.DocsFailed _ _) -> Failed - Right (BR.BuildOk BR.DocsOk _ _) -> Ok + Left _ -> NotTried + Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried + Right (BR.BuildResult BR.DocsFailed _ _) -> Failed + Right (BR.BuildResult BR.DocsOk _ _) -> Ok convertTestsOutcome = case result of - Left (BR.TestsFailed _) -> Failed - Left _ -> NotTried - Right (BR.BuildOk _ BR.TestsNotTried _) -> NotTried - Right (BR.BuildOk _ BR.TestsOk _) -> Ok + Left (BR.TestsFailed _) -> Failed + Left _ -> NotTried + Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried + Right (BR.BuildResult _ BR.TestsOk _) -> Ok cabalInstallID :: PackageIdentifier cabalInstallID = - PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version + PackageIdentifier (mkPackageName "cabal-install") + (mkVersion' Paths_cabal_install.version) -- ------------------------------------------------------------ -- * External format @@ -263,15 +264,15 @@ sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs dispFlag :: (FlagName, Bool) -> Disp.Doc -dispFlag (FlagName name, True) = Disp.text name -dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name +dispFlag (fname, True) = Disp.text (unFlagName fname) +dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname) parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') case name of - ('-':flag) -> return (FlagName flag, False) - flag -> return (FlagName flag, True) + ('-':flag) -> return (mkFlagName flag, False) + flag -> return (mkFlagName flag, True) instance Text.Text InstallOutcome where disp PlanningFailed = Disp.text "PlanningFailed" 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,10 +28,12 @@ import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.ComponentDeps as CD import Distribution.Client.InstallPlan ( InstallPlan ) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.SourcePackage + import Distribution.Package ( PackageId, packageId ) import Distribution.PackageDescription @@ -103,7 +105,7 @@ fromPathTemplate (substPathTemplate env template) where env = initialPathTemplateEnv (BuildReport.package report) - -- ToDo: In principle, we can support $pkgkey, but only + -- TODO: In principle, we can support $pkgkey, but only -- if the configure step succeeds. So add a Maybe field -- to the build report, and either use that or make up -- a fake identifier if it's not available. @@ -121,38 +123,35 @@ fromInstallPlan :: Platform -> CompilerId -> InstallPlan + -> BuildOutcomes -> [(BuildReport, Maybe Repo)] -fromInstallPlan platform comp plan = +fromInstallPlan platform comp plan buildOutcomes = catMaybes - . map (fromPlanPackage platform comp) + . map (\pkg -> fromPlanPackage + platform comp pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) . InstallPlan.toList $ plan fromPlanPackage :: Platform -> CompilerId -> InstallPlan.PlanPackage + -> Maybe BuildOutcome -> Maybe (BuildReport, Maybe Repo) -fromPlanPackage (Platform arch os) comp planPackage = case planPackage of - InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ _) deps) - _ result - -> Just $ ( BuildReport.new os arch comp - (packageId srcPkg) flags - (map packageId (CD.nonSetupDeps deps)) - (Right result) - , extractRepo srcPkg) - - InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result - -> Just $ ( BuildReport.new os arch comp - (packageId srcPkg) flags - (map confSrcId (CD.nonSetupDeps deps)) - (Left result) - , extractRepo srcPkg ) - - _ -> Nothing - +fromPlanPackage (Platform arch os) comp + (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps)) + (Just buildResult) = + Just ( BuildReport.new os arch comp + (packageId srcPkg) flags + (map packageId (CD.nonSetupDeps deps)) + buildResult + , extractRepo srcPkg) where extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo extractRepo _ = Nothing + +fromPlanPackage _ _ _ _ = Nothing + fromPlanningFailure :: Platform -> CompilerId -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] 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 @@ -25,7 +25,7 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup ( RepoContext(..) ) @@ -48,7 +48,7 @@ res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth) case res of (303, redir) -> return $ undefined redir --TODO parse redir - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response {- setAllowRedirects False @@ -89,4 +89,4 @@ res <- postHttp transport verbosity fullURI buildLog (Just auth) case res of (200, _) -> return () - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response diff --git a/Distribution/Client/BuildTarget.hs b/Distribution/Client/BuildTarget.hs deleted file mode 100644 --- a/Distribution/Client/BuildTarget.hs +++ /dev/null @@ -1,1623 +0,0 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildTargets --- Copyright : (c) Duncan Coutts 2012, 2015 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified build targets ------------------------------------------------------------------------------ -module Distribution.Client.BuildTarget ( - - -- * Build targets - BuildTarget(..), - --showBuildTarget, - QualLevel(..), - buildTargetPackage, - buildTargetComponentName, - - -- * Top level convenience - readUserBuildTargets, - resolveUserBuildTargets, - - -- * Parsing user build targets - UserBuildTarget, - parseUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, - - -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, - ) where - -import Distribution.Package - ( Package(..), PackageId, PackageName, packageName ) -import Distribution.Client.Types - ( PackageLocation(..) ) - -import Distribution.PackageDescription - ( PackageDescription - , Executable(..) - , TestSuite(..), TestSuiteInterface(..), testModules - , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), libModules, exeModules ) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..) - , pkgComponents, componentName, componentBuildInfo ) - -import Distribution.Text - ( display, simpleParse ) -import Distribution.Simple.Utils - ( die, lowercase ) -import Distribution.Client.Utils - ( makeRelativeToCwd ) - -import Data.List - ( nub, nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) -import Data.Maybe - ( listToMaybe, maybeToList ) -import Data.Either - ( partitionEithers ) -import Data.Function - ( on ) -import GHC.Generics (Generic) -#if MIN_VERSION_containers(0,5,0) -import qualified Data.Map.Lazy as Map.Lazy -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -#else -import qualified Data.Map as Map.Lazy -import qualified Data.Map as Map -import Data.Map (Map) -#endif -import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif -import Control.Applicative (Alternative(..)) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP - ( (+++), (<++) ) -import Data.Char - ( isSpace, isAlphaNum ) -import System.FilePath as FilePath - ( takeExtension, dropExtension, addTrailingPathSeparator - , splitDirectories, joinPath, splitPath ) -import System.Directory - ( doesFileExist, doesDirectoryExist, canonicalizePath - , getCurrentDirectory ) -import System.FilePath - ( (), (<.>), normalise ) - - --- ------------------------------------------------------------ --- * User build targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a build target. --- --- The main general form has lots of optional parts: --- --- > [ package name | package dir | package .cabal file ] --- > [ [lib:|exe:] component name ] --- > [ module name | source file ] --- --- There's also a special case of a package tarball. It doesn't take part in --- the main general form since we always build a tarball package as a whole. --- --- > [package tar.gz file] --- -data UserBuildTarget = - - -- | A simple target specified by a single part. This is any of the - -- general forms that can be expressed using one part, which are: - -- - -- > cabal build foo -- package name - -- > cabal build ../bar ../bar/bar.cabal -- package dir or package file - -- > cabal build foo -- component name - -- > cabal build Data.Foo -- module name - -- > cabal build Data/Foo.hs bar/Main.hsc -- file name - -- - -- It can also be a package tarball. - -- - -- > cabal build bar.tar.gz - -- - UserBuildTarget1 String - - -- | A qualified target with two parts. This is any of the general - -- forms that can be expressed using two parts, which are: - -- - -- > cabal build foo:foo -- package : component - -- > cabal build foo:Data.Foo -- package : module - -- > cabal build foo:Data/Foo.hs -- package : filename - -- - -- > cabal build ./foo:foo -- package dir : component - -- > cabal build ./foo:Data.Foo -- package dir : module - -- - -- > cabal build ./foo.cabal:foo -- package file : component - -- > cabal build ./foo.cabal:Data.Foo -- package file : module - -- > cabal build ./foo.cabal:Main.hs -- package file : filename - -- - -- > cabal build lib:foo exe:foo -- namespace : component - -- > cabal build foo:Data.Foo -- component : module - -- > cabal build foo:Data/Foo.hs -- component : filename - -- - | UserBuildTarget2 String String - - -- A (very) qualified target with three parts. This is any of the general - -- forms that can be expressed using three parts, which are: - -- - -- > cabal build foo:lib:foo -- package : namespace : component - -- > cabal build foo:foo:Data.Foo -- package : component : module - -- > cabal build foo:foo:Data/Foo.hs -- package : component : filename - -- - -- > cabal build foo/:lib:foo -- pkg dir : namespace : component - -- > cabal build foo/:foo:Data.Foo -- pkg dir : component : module - -- > cabal build foo/:foo:Data/Foo.hs -- pkg dir : component : filename - -- - -- > cabal build foo.cabal:lib:foo -- pkg file : namespace : component - -- > cabal build foo.cabal:foo:Data.Foo -- pkg file : component : module - -- > cabal build foo.cabal:foo:Data/Foo.hs -- pkg file : component : filename - -- - -- > cabal build lib:foo:Data.Foo -- namespace : component : module - -- > cabal build lib:foo:Data/Foo.hs -- namespace : component : filename - -- - | UserBuildTarget3 String String String - - -- A (rediculously) qualified target with four parts. This is any of the - -- general forms that can be expressed using all four parts, which are: - -- - -- > cabal build foo:lib:foo:Data.Foo -- package : namespace : component : module - -- > cabal build foo:lib:foo:Data/Foo.hs -- package : namespace : component : filename - -- - -- > cabal build foo/:lib:foo:Data.Foo -- pkg dir : namespace : component : module - -- > cabal build foo/:lib:foo:Data/Foo.hs -- pkg dir : namespace : component : filename - -- - -- > cabal build foo.cabal:lib:foo:Data.Foo -- pkg file : namespace : component : module - -- > cabal build foo.cabal:lib:foo:Data/Foo.hs -- pkg file : namespace : component : filename - -- - | UserBuildTarget4 String String String String - deriving (Show, Eq, Ord) - - --- ------------------------------------------------------------ --- * Resolved build targets --- ------------------------------------------------------------ - --- | A fully resolved build target. --- -data BuildTarget pkg = - - -- | A package as a whole - -- - BuildTargetPackage pkg - - -- | A specific component - -- - | BuildTargetComponent pkg ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule pkg ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile pkg ComponentName FilePath - deriving (Eq, Ord, Functor, Show, Generic) - - --- | Get the package that the 'BuildTarget' is referring to. --- -buildTargetPackage :: BuildTarget pkg -> pkg -buildTargetPackage (BuildTargetPackage p) = p -buildTargetPackage (BuildTargetComponent p _cn) = p -buildTargetPackage (BuildTargetModule p _cn _mn) = p -buildTargetPackage (BuildTargetFile p _cn _fn) = p - - --- | Get the 'ComponentName' that the 'BuildTarget' is referring to, if any. --- The 'BuildTargetPackage' target kind doesn't refer to any individual --- component, while the component, module and file kinds do. --- -buildTargetComponentName :: BuildTarget pkg -> Maybe ComponentName -buildTargetComponentName (BuildTargetPackage _p) = Nothing -buildTargetComponentName (BuildTargetComponent _p cn) = Just cn -buildTargetComponentName (BuildTargetModule _p cn _mn) = Just cn -buildTargetComponentName (BuildTargetFile _p cn _fn) = Just cn - - --- ------------------------------------------------------------ --- * Top level, do everything --- ------------------------------------------------------------ - - --- | Parse a bunch of command line args as user build targets, failing with an --- error if any targets are unrecognised. --- -readUserBuildTargets :: [String] -> IO [UserBuildTarget] -readUserBuildTargets targetStrs = do - let (uproblems, utargets) = parseUserBuildTargets targetStrs - reportUserBuildTargetProblems uproblems - return utargets - - --- | A 'UserBuildTarget's is just a semi-structured string. We sill have quite --- a bit of work to do to figure out which targets they refer to (ie packages, --- components, file locations etc). --- --- The possible targets are based on the available packages (and their --- locations). It fails with an error if any user string cannot be matched to --- a valid target. --- -resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)] - -> [UserBuildTarget] -> IO [BuildTarget PackageName] -resolveUserBuildTargets pkgs utargets = do - utargets' <- mapM getUserTargetFileStatus utargets - pkgs' <- mapM (uncurry selectPackageInfo) pkgs - pwd <- getCurrentDirectory - let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, btargets) = resolveBuildTargets - primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' - | not (null primaryPkg) - , null utargets = [UserBuildTargetFileStatus1 "./" - (FileStatusExistsDir pwd)] - | otherwise = utargets' - - reportBuildTargetProblems bproblems - return (map (fmap packageName) btargets) - where - selectPrimaryLocalPackage :: FilePath - -> [PackageInfo] - -> ([PackageInfo], [PackageInfo]) - selectPrimaryLocalPackage pwd pkgs' = - let (primary, others) = partition isPrimary pkgs' - in (primary, others) - where - isPrimary PackageInfo { pinfoDirectory = Just (dir,_) } - | dir == pwd = True - isPrimary _ = False - - --- ------------------------------------------------------------ --- * Checking if targets exist as files --- ------------------------------------------------------------ - -data UserBuildTargetFileStatus = - UserBuildTargetFileStatus1 String FileStatus - | UserBuildTargetFileStatus2 String FileStatus String - | UserBuildTargetFileStatus3 String FileStatus String String - | UserBuildTargetFileStatus4 String FileStatus String String String - deriving (Eq, Ord, Show) - -data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath - | FileStatusExistsDir FilePath -- the canonicalised filepath - | FileStatusNotExists Bool -- does the parent dir exist even? - deriving (Eq, Ord, Show) - -getUserTargetFileStatus :: UserBuildTarget -> IO UserBuildTargetFileStatus -getUserTargetFileStatus t = - case t of - UserBuildTarget1 s1 -> - (\f1 -> UserBuildTargetFileStatus1 s1 f1) <$> fileStatus s1 - UserBuildTarget2 s1 s2 -> - (\f1 -> UserBuildTargetFileStatus2 s1 f1 s2) <$> fileStatus s1 - UserBuildTarget3 s1 s2 s3 -> - (\f1 -> UserBuildTargetFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - UserBuildTarget4 s1 s2 s3 s4 -> - (\f1 -> UserBuildTargetFileStatus4 s1 f1 s2 s3 s4) <$> fileStatus s1 - where - fileStatus f = do - fexists <- doesFileExist f - dexists <- doesDirectoryExist f - case splitPath f of - _ | fexists -> FileStatusExistsFile <$> canonicalizePath f - | dexists -> FileStatusExistsDir <$> canonicalizePath f - (d:_) -> FileStatusNotExists <$> doesDirectoryExist d - _ -> error "getUserTargetFileStatus: empty path" - -forgetFileStatus :: UserBuildTargetFileStatus -> UserBuildTarget -forgetFileStatus t = case t of - UserBuildTargetFileStatus1 s1 _ -> UserBuildTarget1 s1 - UserBuildTargetFileStatus2 s1 _ s2 -> UserBuildTarget2 s1 s2 - UserBuildTargetFileStatus3 s1 _ s2 s3 -> UserBuildTarget3 s1 s2 s3 - UserBuildTargetFileStatus4 s1 _ s2 s3 s4 -> UserBuildTarget4 s1 s2 s3 s4 - - --- ------------------------------------------------------------ --- * Parsing user targets --- ------------------------------------------------------------ - - --- | Parse a bunch of 'UserBuildTarget's (purely without throwing exceptions). --- -parseUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) -parseUserBuildTargets = partitionEithers . map parseUserBuildTarget - -parseUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget -parseUserBuildTarget targetstr = - case readPToMaybe parseTargetApprox targetstr of - Nothing -> Left (UserBuildTargetUnrecognised targetstr) - Just tgt -> Right tgt - - where - parseTargetApprox :: Parse.ReadP r UserBuildTarget - parseTargetApprox = - (do a <- tokenQ - return (UserBuildTarget1 a)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- tokenQ - return (UserBuildTarget2 a b)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- tokenQ - _ <- Parse.char ':' - c <- tokenQ - return (UserBuildTarget3 a b c)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - return (UserBuildTarget4 a b c d)) - - token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') - tokenQ = parseHaskellString <++ token - parseHaskellString :: Parse.ReadP r String - parseHaskellString = Parse.readS_to_P reads - - readPToMaybe :: Parse.ReadP a a -> String -> Maybe a - readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - --- | Syntax error when trying to parse a 'UserBuildTarget'. -data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show - --- | Throw an exception with a formatted message if there are any problems. --- -reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die $ unlines - [ "Unrecognised build target syntax for '" ++ name ++ "'." - | name <- target ] - ++ "Syntax:\n" - ++ " - build [package]\n" - ++ " - build [package:]component\n" - ++ " - build [package:][component:]module\n" - ++ " - build [package:][component:]file\n" - ++ " where\n" - ++ " package is a package name, package dir or .cabal file\n\n" - ++ "Examples:\n" - ++ " - build foo -- package name\n" - ++ " - build tests -- component name\n" - ++ " (name of library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n\n" - ++ "An ambigious target can be qualified by package, component\n" - ++ "and/or component kind (lib|exe|test|bench)\n" - ++ " - build foo:tests -- component qualified by package\n" - ++ " - build tests:Data.Foo -- module qualified by component\n" - ++ " - build lib:foo -- component qualified by kind" - - --- | Render a 'UserBuildTarget' back as the external syntax. This is mainly for --- error messages. --- -showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . components - where - components (UserBuildTarget1 s1) = [s1] - components (UserBuildTarget2 s1 s2) = [s1,s2] - components (UserBuildTarget3 s1 s2 s3) = [s1,s2,s3] - components (UserBuildTarget4 s1 s2 s3 s4) = [s1,s2,s3,s4] - -showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String -showBuildTarget ql = showUserBuildTarget . forgetFileStatus - . head . renderBuildTarget ql - - --- ------------------------------------------------------------ --- * Resolving user targets to build targets --- ------------------------------------------------------------ - - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveBuildTargets :: [PackageInfo] -- any primary pkg, e.g. cur dir - -> [PackageInfo] -- all the other local packages - -> [UserBuildTargetFileStatus] - -> ([BuildTargetProblem], [BuildTarget PackageInfo]) -resolveBuildTargets ppinfo opinfo = - partitionEithers - . map (resolveBuildTarget ppinfo opinfo) - -resolveBuildTarget :: [PackageInfo] -> [PackageInfo] - -> UserBuildTargetFileStatus - -> Either BuildTargetProblem (BuildTarget PackageInfo) -resolveBuildTarget ppinfo opinfo userTarget = - case findMatch (matcher userTarget) of - Unambiguous target -> Right target - None errs -> Left (classifyMatchErrors errs) - Ambiguous exactMatch targets -> - case disambiguateBuildTargets - matcher userTarget exactMatch - targets of - Right targets' -> Left (BuildTargetAmbiguous userTarget' targets') - Left ((m, ms):_) -> Left (MatchingInternalError userTarget' m ms) - Left [] -> internalError "resolveBuildTarget" - where - matcher = matchBuildTarget ppinfo opinfo - - userTarget' = forgetFileStatus userTarget - - classifyMatchErrors errs - | not (null expected) - = let (things, got:_) = unzip expected in - BuildTargetExpected userTarget' things got - - | not (null nosuch) - = BuildTargetNoSuch userTarget' nosuch - - | otherwise - = internalError $ "classifyMatchErrors: " ++ show errs - where - expected = [ (thing, got) - | (_, MatchErrorExpected thing got) - <- map (innerErr Nothing) errs ] - nosuch = [ (inside, thing, got, alts) - | (inside, MatchErrorNoSuch thing got alts) - <- map (innerErr Nothing) errs ] - - innerErr _ (MatchErrorIn kind thing m) - = innerErr (Just (kind,thing)) m - innerErr c m = (c,m) - - --- | The various ways that trying to resolve a 'UserBuildTarget' to a --- 'BuildTarget' can fail. --- -data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget - [(Maybe (String, String), String, String, [String])] - -- ^ [([in thing], no such thing, actually got, alternatives)] - | BuildTargetAmbiguous UserBuildTarget - [(UserBuildTarget, BuildTarget PackageInfo)] - - | MatchingInternalError UserBuildTarget (BuildTarget PackageInfo) - [(UserBuildTarget, [BuildTarget PackageInfo])] - - -disambiguateBuildTargets - :: (UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo)) - -> UserBuildTargetFileStatus -> Bool - -> [BuildTarget PackageInfo] - -> Either [(BuildTarget PackageInfo, - [(UserBuildTarget, [BuildTarget PackageInfo])])] - [(UserBuildTarget, BuildTarget PackageInfo)] -disambiguateBuildTargets matcher matchInput exactMatch matchResults = - case partitionEithers results of - (errs@(_:_), _) -> Left errs - ([], ok) -> Right ok - where - -- So, here's the strategy. We take the original match results, and make a - -- table of all their renderings at all qualification levels. - -- Note there can be multiple renderings at each qualification level. - matchResultsRenderings :: [(BuildTarget PackageInfo, [UserBuildTargetFileStatus])] - matchResultsRenderings = - [ (matchResult, matchRenderings) - | matchResult <- matchResults - , let matchRenderings = - [ rendering - | ql <- [QL1 .. QL4] - , rendering <- renderBuildTarget ql matchResult ] - ] - - -- Of course the point is that we're looking for renderings that are - -- unambiguous matches. So we build another memo table of all the matches - -- for all of those renderings. So by looking up in this table we can see - -- if we've got an unambiguous match. - - memoisedMatches :: Map UserBuildTargetFileStatus - (Match (BuildTarget PackageInfo)) - memoisedMatches = - -- avoid recomputing the main one if it was an exact match - (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) - else id) - $ Map.Lazy.fromList - [ (rendering, matcher rendering) - | rendering <- concatMap snd matchResultsRenderings ] - - -- Finally, for each of the match results, we go through all their - -- possible renderings (in order of qualification level, though remember - -- there can be multiple renderings per level), and find the first one - -- that has an unambiguous match. - results :: [Either (BuildTarget PackageInfo, - [(UserBuildTarget, [BuildTarget PackageInfo])]) - (UserBuildTarget, BuildTarget PackageInfo)] - results = - [ case findUnambiguous originalMatch matchRenderings of - Just unambiguousRendering -> - Right ( forgetFileStatus unambiguousRendering - , originalMatch) - - -- This case is an internal error, but we bubble it up and report it - Nothing -> - Left ( originalMatch - , [ (forgetFileStatus rendering, matches) - | rendering <- matchRenderings - , let (ExactMatch _ matches) = - memoisedMatches Map.! rendering - ] ) - - | (originalMatch, matchRenderings) <- matchResultsRenderings ] - - findUnambiguous :: BuildTarget PackageInfo -> [UserBuildTargetFileStatus] - -> Maybe UserBuildTargetFileStatus - findUnambiguous _ [] = Nothing - findUnambiguous t (r:rs) = - case memoisedMatches Map.! r of - ExactMatch _ [t'] | fmap packageName t == fmap packageName t' - -> Just r - ExactMatch _ _ -> findUnambiguous t rs - InexactMatch _ _ -> internalError "InexactMatch" - NoMatch _ _ -> internalError "NoMatch" - -internalError :: String -> a -internalError msg = - error $ "BuildTargets: internal error: " ++ msg - - -data QualLevel = QL1 | QL2 | QL3 | QL4 - deriving (Enum, Show) - -renderBuildTarget :: QualLevel -> BuildTarget PackageInfo - -> [UserBuildTargetFileStatus] -renderBuildTarget ql t = - case t of - BuildTargetPackage p -> - case ql of - QL1 -> [t1 (dispP p)] - QL2 -> [t1' pf fs | (pf, fs) <- dispPF p] - QL3 -> [] - QL4 -> [] - - BuildTargetComponent p c -> - case ql of - QL1 -> [t1 (dispC p c)] - QL2 -> [t2 (dispP p) (dispC p c), - t2 (dispK c) (dispC p c)] - QL3 -> [t3 (dispP p) (dispK c) (dispC p c)] - QL4 -> [] - - BuildTargetModule p c m -> - case ql of - QL1 -> [t1 (dispM m)] - QL2 -> [t2 (dispP p) (dispM m), - t2 (dispC p c) (dispM m)] - QL3 -> [t3 (dispP p) (dispC p c) (dispM m), - t3 (dispK c) (dispC p c) (dispM m)] - QL4 -> [t4 (dispP p) (dispK c) (dispC p c) (dispM m)] - - BuildTargetFile p c f -> - case ql of - QL1 -> [t1 f] - QL2 -> [t2 (dispP p) f, - t2 (dispC p c) f] - QL3 -> [t3 (dispP p) (dispC p c) f, - t3 (dispK c) (dispC p c) f] - QL4 -> [t4 (dispP p) (dispK c) (dispC p c) f] - where - t1 s1 = UserBuildTargetFileStatus1 s1 none - t1' s1 = UserBuildTargetFileStatus1 s1 - t2 s1 = UserBuildTargetFileStatus2 s1 none - t3 s1 = UserBuildTargetFileStatus3 s1 none - t4 s1 = UserBuildTargetFileStatus4 s1 none - none = FileStatusNotExists False - - dispP = display . packageName - dispC = componentStringName . packageName - dispK = showComponentKindShort . componentKind - dispM = display - - dispPF p = [ (addTrailingPathSeparator drel, FileStatusExistsDir dabs) - | PackageInfo { pinfoDirectory = Just (dabs,drel) } <- [p] ] - ++ [ (frel, FileStatusExistsFile fabs) - | PackageInfo { pinfoPackageFile = Just (fabs,frel) } <- [p] ] - - --- | Throw an exception with a formatted message if there are any problems. --- -reportBuildTargetProblems :: [BuildTargetProblem] -> IO () -reportBuildTargetProblems problems = do - - case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of - [] -> return () - ((target, originalMatch, renderingsAndMatches):_) -> - die $ "Internal error in build target matching. It should always be " - ++ "possible to find a syntax that's sufficiently qualified to " - ++ "give an unambigious match. However when matching '" - ++ showUserBuildTarget target ++ "' we found " - ++ showBuildTarget QL1 originalMatch - ++ " (" ++ showBuildTargetKind originalMatch ++ ") which does not " - ++ "have an unambigious syntax. The possible syntax and the " - ++ "targets they match are as follows:\n" - ++ unlines - [ "'" ++ showUserBuildTarget rendering ++ "' which matches " - ++ intercalate ", " - [ showBuildTarget QL1 match ++ - " (" ++ showBuildTargetKind match ++ ")" - | match <- matches ] - | (rendering, matches) <- renderingsAndMatches ] - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target ++ - "'.\n" ++ unlines - [ (case inside of - Just (kind, thing) - -> "The " ++ kind ++ " " ++ thing ++ " has no " - Nothing -> "There is no ") - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got, _alts) <- nosuch' ] ++ "." - ++ if null alternatives then "" else - "\nPerhaps you meant " ++ intercalate ";\nor " - [ "the " ++ thing ++ " " ++ intercalate " or " alts - | (thing, alts) <- alternatives ] - | (inside, nosuch') <- groupByContainer nosuch - , let alternatives = - [ (thing, take 10 alts) --TODO: select best ones - | (thing,_got,alts@(_:_)) <- nosuch' ] - ] - | (target, nosuch) <- targets - , let groupByContainer = - map (\g@((inside,_,_,_):_) -> - (inside, [ (thing,got,alts) - | (_,thing,got,alts) <- g ])) - . groupBy ((==) `on` (\(x,_,_,_) -> x)) - . sortBy (compare `on` (\(x,_,_,_) -> x)) - ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target - ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - where - showBuildTargetKind (BuildTargetPackage _ ) = "package" - showBuildTargetKind (BuildTargetComponent _ _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _ _) = "file" - - ----------------------------------- --- Top level BuildTarget matcher --- - -matchBuildTarget :: [PackageInfo] -> [PackageInfo] - -> UserBuildTargetFileStatus - -> Match (BuildTarget PackageInfo) -matchBuildTarget ppinfo opinfo = \utarget -> - nubMatchesBy ((==) `on` (fmap packageName)) $ - case utarget of - UserBuildTargetFileStatus1 str1 fstatus1 -> - matchBuildTarget1 ppinfo opinfo str1 fstatus1 - - UserBuildTargetFileStatus2 str1 fstatus1 str2 -> - matchBuildTarget2 pinfo str1 fstatus1 str2 - - UserBuildTargetFileStatus3 str1 fstatus1 str2 str3 -> - matchBuildTarget3 pinfo str1 fstatus1 str2 str3 - - UserBuildTargetFileStatus4 str1 fstatus1 str2 str3 str4 -> - matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 - where - pinfo = ppinfo ++ opinfo - --TODO: sort this out - - -matchBuildTarget1 :: [PackageInfo] -> [PackageInfo] - -> String -> FileStatus -> Match (BuildTarget PackageInfo) -matchBuildTarget1 ppinfo opinfo = \str1 fstatus1 -> - match1Cmp pcinfo str1 - match1Pkg pinfo str1 fstatus1 - match1Cmp ocinfo str1 - match1Mod cinfo str1 - match1Fil pinfo str1 fstatus1 - where - pinfo = ppinfo ++ opinfo - cinfo = concatMap pinfoComponents pinfo - pcinfo = concatMap pinfoComponents ppinfo - ocinfo = concatMap pinfoComponents opinfo - - -matchBuildTarget2 :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget2 pinfo str1 fstatus1 str2 = - match2PkgCmp pinfo str1 fstatus1 str2 - <|> match2KndCmp cinfo str1 str2 - match2PkgMod pinfo str1 fstatus1 str2 - match2CmpMod cinfo str1 str2 - match2PkgFil pinfo str1 fstatus1 str2 - match2CmpFil cinfo str1 str2 - where - cinfo = concatMap pinfoComponents pinfo - --TODO: perhaps we actually do want to prioritise local/primary components - - -matchBuildTarget3 :: [PackageInfo] -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget3 pinfo str1 fstatus1 str2 str3 = - match3PkgKndCmp pinfo str1 fstatus1 str2 str3 - match3PkgCmpMod pinfo str1 fstatus1 str2 str3 - match3PkgCmpFil pinfo str1 fstatus1 str2 str3 - match3KndCmpMod cinfo str1 str2 str3 - match3KndCmpFil cinfo str1 str2 str3 - where - cinfo = concatMap pinfoComponents pinfo - - -matchBuildTarget4 :: [PackageInfo] - -> String -> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 = - match4PkgKndCmpMod pinfo str1 fstatus1 str2 str3 str4 - match4PkgKndCmpFil pinfo str1 fstatus1 str2 str3 str4 - - ------------------------------------- --- Individual BuildTarget matchers --- - -match1Pkg :: [PackageInfo] -> String -> FileStatus - -> Match (BuildTarget PackageInfo) -match1Pkg pinfo = \str1 fstatus1 -> do - guardPackage str1 fstatus1 - p <- matchPackage pinfo str1 fstatus1 - return (BuildTargetPackage p) - -match1Cmp :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) -match1Cmp cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) - -match1Mod :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) -match1Mod cs = \str1 -> do - guardModuleName str1 - let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str1 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match1Fil :: [PackageInfo] -> String -> FileStatus - -> Match (BuildTarget PackageInfo) -match1Fil ps str1 fstatus1 = - expecting "file" str1 $ do - (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile - return (BuildTargetFile p (cinfoName c) filepath) - ---- - -match2PkgCmp :: [PackageInfo] - -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgCmp ps = \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - return (BuildTargetComponent p (cinfoName c)) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package - -match2KndCmp :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2KndCmp cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) - -match2PkgMod :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgMod ps = \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardModuleName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (BuildTargetModule p (cinfoName c) m) - -match2CmpMod :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2CmpMod cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match2PkgFil :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgFil ps str1 fstatus1 str2 = do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) str2 - return (BuildTargetFile p (cinfoName c) filepath) - -match2CmpFil :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2CmpFil cs str1 str2 = do - guardComponentName str1 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str2 - return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) - ---- - -match3PkgKndCmp :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgKndCmp ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - return (BuildTargetComponent p (cinfoName c)) - -match3PkgCmpMod :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgCmpMod ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - guardModuleName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule p (cinfoName c) m) - -match3KndCmpMod :: [ComponentInfo] - -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match3KndCmpMod cs = \str1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - guardModuleName str3 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match3PkgCmpFil :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgCmpFil ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (BuildTargetFile p (cinfoName c) filepath) - -match3KndCmpFil :: [ComponentInfo] -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match3KndCmpFil cs = \str1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) - --- - -match4PkgKndCmpMod :: [PackageInfo] - -> String-> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match4PkgKndCmpMod ps = \str1 fstatus1 str2 str3 str4 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - guardModuleName str4 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str4 - return (BuildTargetModule p (cinfoName c) m) - -match4PkgKndCmpFil :: [PackageInfo] - -> String -> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match4PkgKndCmpFil ps = \str1 fstatus1 str2 str3 str4 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str4 - return (BuildTargetFile p (cinfoName c) filepath) - - -------------------------------- --- Package and component info --- - -data PackageInfo = PackageInfo { - pinfoId :: PackageId, - pinfoLocation :: PackageLocation (), - pinfoDirectory :: Maybe (FilePath, FilePath), - pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [ComponentInfo] - } - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackage :: PackageInfo, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] - } - -type ComponentStringName = String - -instance Package PackageInfo where - packageId = pinfoId - ---TODO: [required eventually] need the original GenericPackageDescription or --- the flattening thereof because we need to be able to target modules etc --- that are not enabled in the current configuration. -selectPackageInfo :: PackageDescription -> PackageLocation a -> IO PackageInfo -selectPackageInfo pkg loc = do - (pkgdir, pkgfile) <- - case loc of - --TODO: local tarballs, remote tarballs etc - LocalUnpackedPackage dir -> do - dirabs <- canonicalizePath dir - dirrel <- makeRelativeToCwd dirabs - --TODO: ought to get this earlier in project reading - let fileabs = dirabs display (packageName pkg) <.> "cabal" - filerel = dirrel display (packageName pkg) <.> "cabal" - exists <- doesFileExist fileabs - return ( Just (dirabs, dirrel) - , if exists then Just (fileabs, filerel) else Nothing - ) - _ -> return (Nothing, Nothing) - let pinfo = - PackageInfo { - pinfoId = packageId pkg, - pinfoLocation = fmap (const ()) loc, - pinfoDirectory = pkgdir, - pinfoPackageFile = pkgfile, - pinfoComponents = selectComponentInfo pinfo pkg - } - return pinfo - - -selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] -selectComponentInfo pinfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName (packageName pkg) (componentName c), - cinfoPackage = pinfo, - cinfoSrcDirs = hsSourceDirs bi, --- [ pkgroot srcdir --- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) --- , srcdir <- hsSourceDirs bi ], - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoCFiles = cSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - - -componentStringName :: PackageName -> ComponentName -> ComponentStringName -componentStringName pkgname CLibName = display pkgname -componentStringName _ (CExeName name) = name -componentStringName _ (CTestName name) = name -componentStringName _ (CBenchName name) = name - -componentModules :: Component -> [ModuleName] -componentModules (CLib lib) = libModules lib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - - ------------------------------- --- Matching component kinds --- - -data ComponentKind = LibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Show) - -componentKind :: ComponentName -> ComponentKind -componentKind CLibName = LibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: ComponentInfo -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s `elem` ["lib", "library"] = increaseConfidence >> return LibKind - | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind - | s `elem` ["tst", "test", "test-suite"] = increaseConfidence - >> return TestKind - | s `elem` ["bench", "benchmark"] = increaseConfidence - >> return BenchKind - | otherwise = matchErrorExpected - "component kind" s - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - ------------------------------- --- Matching package targets --- - -guardPackage :: String -> FileStatus -> Match () -guardPackage str fstatus = - guardPackageName str - <|> guardPackageDir str fstatus - <|> guardPackageFile str fstatus - - -guardPackageName :: String -> Match () -guardPackageName s - | validPackgageName s = increaseConfidence - | otherwise = matchErrorExpected "package name" s - where - -validPackgageName :: String -> Bool -validPackgageName s = - all validPackgageNameChar s - && not (null s) - where - validPackgageNameChar c = isAlphaNum c || c == '-' - - -guardPackageDir :: String -> FileStatus -> Match () -guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence -guardPackageDir str _ = matchErrorExpected "package directory" str - - -guardPackageFile :: String -> FileStatus -> Match () -guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" - = increaseConfidence -guardPackageFile str _ = matchErrorExpected "package .cabal file" str - - -matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo -matchPackage pinfo = \str fstatus -> - orNoThingIn "project" "" $ - matchPackageName pinfo str - (matchPackageDir pinfo str fstatus - <|> matchPackageFile pinfo str fstatus) - - -matchPackageName :: [PackageInfo] -> String -> Match PackageInfo -matchPackageName ps = \str -> do - guard (validPackgageName str) - orNoSuchThing "package" str - (map (display . packageName) ps) $ - increaseConfidenceFor $ - matchInexactly caseFold (display . packageName) ps str - - -matchPackageDir :: [PackageInfo] - -> String -> FileStatus -> Match PackageInfo -matchPackageDir ps = \str fstatus -> - case fstatus of - FileStatusExistsDir canondir -> - orNoSuchThing "package directory" str (map (snd . fst) dirs) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) dirs canondir - _ -> mzero - where - dirs = [ ((dabs,drel),p) - | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] - - -matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo -matchPackageFile ps = \str fstatus -> do - case fstatus of - FileStatusExistsFile canonfile -> - orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) files canonfile - _ -> mzero - where - files = [ ((fabs,frel),p) - | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] - ---TODO: test outcome when dir exists but doesn't match any known one - ---TODO: perhaps need another distinction, vs no such thing, point is the --- thing is not known, within the project, but could be outside project - - ------------------------------- --- Matching component targets --- - - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - - -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo -matchComponentName cs str = - orNoSuchThing "component" str (map cinfoStrName cs) - $ increaseConfidenceFor - $ matchInexactly caseFold cinfoStrName cs str - - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - (map render cs) - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - (\c -> (cinfoKind c, cinfoStrName c)) - cs - (ckind, str) - where - render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c - - ------------------------------- --- Matching module targets --- - -guardModuleName :: String -> Match () -guardModuleName s = - case simpleParse s :: Maybe ModuleName of - Just _ -> increaseConfidence - _ | all validModuleChar s - && not (null s) -> return () - | otherwise -> matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str (map display ms) - $ increaseConfidenceFor - $ matchInexactly caseFold display ms str - - -matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) -matchModuleNameAnd ms str = - orNoSuchThing "module" str (map (display . fst) ms) - $ increaseConfidenceFor - $ matchInexactly caseFold (display . fst) ms str - - ------------------------------- --- Matching file targets --- - -matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus - -> Match (FilePath, PackageInfo) -matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = - increaseConfidenceFor $ - matchDirectoryPrefix pkgdirs filepath - where - pkgdirs = [ (dir, p) - | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] -matchPackageDirectoryPrefix _ _ = mzero - - -matchComponentFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentFile cs str = - orNoSuchThing "file" str [] $ - matchComponentModuleFile cs str - <|> matchComponentOtherFile cs str - - -matchComponentOtherFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentOtherFile cs = - matchFile - [ (file, c) - | c <- cs - , file <- cinfoHsFiles c - ++ cinfoCFiles c - ++ cinfoJsFiles c - ] - - -matchComponentModuleFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentModuleFile cs str = do - matchFile - [ (normalise (d toFilePath m), c) - | c <- cs - , d <- cinfoSrcDirs c - , m <- cinfoModules c - ] - (dropExtension (normalise str)) - --- utils - -matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchFile fs = - increaseConfidenceFor - . matchInexactly caseFold fst fs - -matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchDirectoryPrefix dirs filepath = - tryEach $ - [ (file, x) - | (dir,x) <- dirs - , file <- maybeToList (stripDirectory dir) ] - where - stripDirectory :: FilePath -> Maybe FilePath - stripDirectory dir = - joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit - - filepathsplit = splitDirectories filepath - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we --- can run a matcher against an input using 'findMatch'. --- -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show - -type Confidence = Int - -data MatchError = MatchErrorExpected String String -- thing got - | MatchErrorNoSuch String String [String] -- thing got alts - | MatchErrorIn String String MatchError -- kind thing - deriving (Show, Eq) - - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) - -instance Applicative Match where - pure a = ExactMatch 0 [a] - (<*>) = ap - -instance Alternative Match where - empty = NoMatch 0 [] - (<|>) = matchPlus - -instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ msum (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ msum (map f xs) - -instance MonadPlus Match where - mzero = empty - mplus = matchPlus - -() :: Match a -> Match a -> Match a -() = matchPlusShadowing - -infixl 3 - -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') - --- | Combine two matchers. This is similar to 'matchPlus' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b - - ------------------------------- --- Various match primitives --- - -matchErrorExpected :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] - -matchErrorNoSuch :: String -> String -> [String] -> Match a -matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> [String] -> Match a -> Match a -orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts -orNoSuchThing _ _ _ m = m - -orNoThingIn :: String -> String -> Match a -> Match a -orNoThingIn kind name (NoMatch n ms) = - NoMatch n [ MatchErrorIn kind name m | m <- ms ] -orNoThingIn _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) -nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) - -nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) -nubMatchErrors (ExactMatch d xs) = ExactMatch d xs -nubMatchErrors (InexactMatch d xs) = InexactMatch d xs - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = mzero -exactMatches xs = ExactMatch 0 xs - -inexactMatches [] = mzero -inexactMatches xs = InexactMatch 0 xs - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Match a -> MaybeAmbiguous a -findMatch match = - case nubMatchErrors match of - NoMatch _ msgs -> None msgs - ExactMatch _ [x] -> Unambiguous x - InexactMatch _ [x] -> Unambiguous x - ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" - InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" - ExactMatch _ xs -> Ambiguous True xs - InexactMatch _ xs -> Ambiguous False xs - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] - deriving Show - - ------------------------------- --- Basic matchers --- - --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) -matchExactly key xs = - \k -> case Map.lookup k m of - Nothing -> mzero - Just ys -> exactMatches ys - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) - -> [a] -> (k -> Match a) -matchInexactly cannonicalise key xs = - \k -> case Map.lookup k m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise k) m' of - Just ys -> inexactMatches ys - Nothing -> mzero - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - - ------------------------------- --- Example inputs --- - -{- -ex1pinfo :: [PackageInfo] -ex1pinfo = - [ PackageInfo { - pinfoName = PackageName "foo", - pinfoDirectory = Just "/the/foo", - pinfoPackageFile = Just "/the/foo/foo.cabal", - pinfoComponents = [] - } - , PackageInfo { - pinfoName = PackageName "bar", - pinfoDirectory = Just "/the/bar", - pinfoPackageFile = Just "/the/bar/bar.cabal", - pinfoComponents = [] - } - ] --} -{- -stargets = - [ BuildTargetComponent (CExeName "foo") - , BuildTargetModule (CExeName "foo") (mkMn "Foo") - , BuildTargetModule (CExeName "tst") (mkMn "Foo") - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - -{- -ex_cs :: [ComponentInfo] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} - diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Check @@ -17,8 +18,12 @@ import Control.Monad ( when, unless ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) +#else +import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) +#endif + import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) @@ -30,7 +35,7 @@ check :: Verbosity -> IO Bool check verbosity = do pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile + ppd <- readGenericPackageDescription verbosity pdfile -- flatten the generic package description into a regular package -- description -- TODO: this may give more warnings than it should give; diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdBench.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: bench +-- +module Distribution.Client.CmdBench ( + -- * The @bench@ CLI and action + benchCommand, + benchAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import Control.Monad (when) + + +benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +benchCommand = Client.installCommand { + commandName = "new-bench", + commandSynopsis = "Run benchmarks", + commandUsage = usageAlternatives "new-bench" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified benchmarks, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any benchmark in any package in the project can be specified. " + ++ "A package can be specified in which case all the benchmarks in the " + ++ "package are run. The default is to run all the benchmarks in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-bench\n" + ++ " Run all the benchmarks in the package in the current directory\n" + ++ " " ++ pname ++ " new-bench pkgname\n" + ++ " Run all the benchmarks in the package named pkgname\n" + ++ " " ++ pname ++ " new-bench cname\n" + ++ " Run the benchmark named cname\n" + ++ " " ++ pname ++ " new-bench cname -O2\n" + ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The bench command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'bench'." + + -- Interpret the targets on the command line as bench targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return elaboratedPlan' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @bench@ command we select all buildable benchmarks, +-- or fail if there are no benchmarks or no buildable benchmarks. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable benchmark targets then we select those + | not (null targetsBenchBuildable) + = Right targetsBenchBuildable + + -- If there are benchmarks but none are buildable then we report those + | not (null targetsBench) + = Left (TargetProblemNoneEnabled targetSelector targetsBench) + + -- If there are no benchmarks but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoBenchmarks targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsBenchBuildable = selectBuildableTargets + . filterTargetsKind BenchKind + $ targets + + targetsBench = forgetTargetsDetail + . filterTargetsKind BenchKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @bench@ command we just need to check it is a benchmark, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CBenchName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotBenchmark pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches benchmarks but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no benchmarks + | TargetProblemNoBenchmarks (TargetSelector PackageId) + + -- | The 'TargetSelector' refers to a component that is not a benchmark + | TargetProblemComponentNotBenchmark PackageId ComponentName + + -- | Asking to benchmark an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "benchmark" targetSelector targets + +renderTargetProblem (TargetProblemNoBenchmarks targetSelector) = + "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any benchmarks." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= BenchKind + -> "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "benchmark" targetSelector + where + targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter + targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter + targetSelectorFilter (TargetComponent _ _ _) = Nothing + +renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) = + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The bench command can only run benchmarks as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -1,32 +1,71 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild ( + -- * The @build@ CLI and action + buildCommand, buildAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget ) where import Distribution.Client.ProjectOrchestration - ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets - , ProjectBuildContext(..), runProjectBuildPhase - , printPlan, reportBuildFailures ) -import Distribution.Client.ProjectConfig - ( BuildTimeSettings(..) ) -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) -import Distribution.Client.BuildTarget - ( readUserBuildTargets ) +import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity - ( normal ) + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) -import Control.Monad (unless) +import qualified Data.Map as Map +buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +buildCommand = Client.installCommand { + commandName = "new-build", + commandSynopsis = "Compile targets within the project.", + commandUsage = usageAlternatives "new-build" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-build\n" + ++ " Build the package in the current directory or all packages in the project\n" + ++ " " ++ pname ++ " new-build pkgname\n" + ++ " Build the package named pkgname in the project\n" + ++ " " ++ pname ++ " new-build ./pkgfoo\n" + ++ " Build the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " new-build cname\n" + ++ " Build the component named cname in the project\n" + ++ " " ++ pname ++ " new-build cname --enable-profiling\n" + ++ " Build the component in profiling mode (including dependencies as needed)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + -- | The @build@ command does a lot. It brings the install plan up to date, -- selects that part of the plan needed by the given or implicit targets and -- then executes the plan. @@ -36,35 +75,123 @@ -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -buildAction (configFlags, configExFlags, installFlags, haddockFlags) +buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig - buildCtx@ProjectBuildContext{buildSettings} <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \_ _ _ -> return (), - hookSelectPlanSubset = selectBuildTargets userTargets - } + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings - printPlan verbosity buildCtx + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - unless (buildSettingDryRun buildSettings) $ do - plan <- runProjectBuildPhase - verbosity - buildCtx - reportBuildFailures plan + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return elaboratedPlan'' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags - -- When we interpret the targets on the command line, interpret them as - -- repl targets (as opposed to say repl or haddock targets). - selectBuildTargets = - selectTargets - BuildDefaultComponents - BuildSpecificComponent +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable and disabled +-- tests\/benchmarks, fail if there are no such components +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @build@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build" problem +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build" targetSelector targets +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build" targetSelector + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs --- a/Distribution/Client/CmdConfigure.hs +++ b/Distribution/Client/CmdConfigure.hs @@ -1,20 +1,71 @@ +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure ( + configureCommand, configureAction, ) where import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig + ( writeProjectLocalExtraConfig ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Utils + ( wrapText ) +import qualified Distribution.Client.Setup as Client +configureCommand :: CommandUI (ConfigFlags, ConfigExFlags + ,InstallFlags, HaddockFlags) +configureCommand = Client.installCommand { + commandName = "new-configure", + commandSynopsis = "Add extra project configuration", + commandUsage = usageAlternatives "new-configure" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Adjust how the project is built by setting additional package flags " + ++ "and other flags.\n\n" + + ++ "The configuration options are written to the 'cabal.project.local' " + ++ "file (or '$project_file.local', if '--project-file' is specified) " + ++ "which extends the configuration from the 'cabal.project' file " + ++ "(if any). This combination is used as the project configuration for " + ++ "all other commands (such as 'new-build', 'new-repl' etc) though it " + ++ "can be extended/overridden on a per-command basis.\n\n" + + ++ "The new-configure command also checks that the project configuration " + ++ "will work. In particular it checks that there is a consistent set of " + ++ "dependencies for the project as a whole.\n\n" + + ++ "The 'cabal.project.local' file persists across 'new-clean' but is " + ++ "overwritten on the next use of the 'new-configure' command. The " + ++ "intention is that the 'cabal.project' file should be kept in source " + ++ "control but the 'cabal.project.local' should not.\n\n" + + ++ "It is never necessary to use the 'new-configure' command. It is " + ++ "merely a convenience in cases where you do not want to specify flags " + ++ "to 'new-build' (and other commands) every time and yet do not want " + ++ "to alter the 'cabal.project' persistently.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-configure --with-compiler ghc-7.10.3\n" + ++ " Adjust the project configuration to use the given compiler\n" + ++ " program and check the resulting configuration works.\n" + ++ " " ++ pname ++ " new-configure\n" + ++ " Reset the local configuration to empty and check the overall\n" + ++ " project configuration works.\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + -- | To a first approximation, the @configure@ just runs the first phase of -- the @build@ command where we bring the install plan up to date (thus -- checking that it's possible). @@ -27,34 +78,41 @@ -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags) +configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there + baseCtx <- establishProjectBaseContext verbosity cliConfig + + -- Write out the @cabal.project.local@ so it gets picked up by the + -- planning phase. + writeProjectLocalExtraConfig (distDirLayout baseCtx) + cliConfig + buildCtx <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \projectRootDir _ cliConfig -> - -- Write out the @cabal.project.local@ so it gets picked up by the - -- planning phase. - writeProjectLocalExtraConfig projectRootDir cliConfig, + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - hookSelectPlanSubset = return - } + -- TODO: Select the same subset of targets as 'CmdBuild' would + -- pick (ignoring, for example, executables in libraries + -- we depend on). But we don't want it to fail, so actually we + -- have to do it slightly differently from build. + return elaboratedPlan - --TODO: Hmm, but we don't have any targets. Currently this prints what we - -- would build if we were to build everything. Could pick implicit target like "." - --TODO: should we say what's in the project (+deps) as a whole? - printPlan - verbosity - buildCtx { - buildSettings = (buildSettings buildCtx) { - buildSettingDryRun = True - } - } + let baseCtx' = baseCtx { + buildSettings = (buildSettings baseCtx) { + buildSettingDryRun = True + } + } + + -- TODO: Hmm, but we don't have any targets. Currently this prints + -- what we would build if we were to build everything. Could pick + -- implicit target like "." + -- + -- TODO: should we say what's in the project (+deps) as a whole? + printPlan verbosity baseCtx' buildCtx where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdErrorMessages.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +-- | Utilities to help format error messages for the various CLI commands. +-- +module Distribution.Client.CmdErrorMessages ( + module Distribution.Client.CmdErrorMessages, + module Distribution.Client.TargetSelector, + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.TargetSelector + ( componentKind, showTargetSelector ) + +import Distribution.Package + ( packageId, packageName ) +import Distribution.Types.ComponentName + ( showComponentName ) +import Distribution.Solver.Types.OptionalStanza + ( OptionalStanza(..) ) +import Distribution.Text + ( display ) + +import Data.Maybe (isNothing) +import Data.List (sortBy, groupBy, nub) +import Data.Function (on) + + +----------------------- +-- Singular or plural +-- + +-- | A tag used in rendering messages to distinguish singular or plural. +-- +data Plural = Singular | Plural + +-- | Used to render a singular or plural version of something +-- +-- > plural (listPlural theThings) "it is" "they are" +-- +plural :: Plural -> a -> a -> a +plural Singular si _pl = si +plural Plural _si pl = pl + +-- | Singular for singleton lists and plural otherwise. +-- +listPlural :: [a] -> Plural +listPlural [_] = Singular +listPlural _ = Plural + + +-------------------- +-- Rendering lists +-- + +-- | Render a list of things in the style @foo, bar and baz@ +renderListCommaAnd :: [String] -> String +renderListCommaAnd [] = "" +renderListCommaAnd [x] = x +renderListCommaAnd [x,x'] = x ++ " and " ++ x' +renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs + +-- | Render a list of things in the style @blah blah; this that; and the other@ +renderListSemiAnd :: [String] -> String +renderListSemiAnd [] = "" +renderListSemiAnd [x] = x +renderListSemiAnd [x,x'] = x ++ "; and " ++ x' +renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs + +-- | When rendering lists of things it often reads better to group related +-- things, e.g. grouping components by package name +-- +-- > renderListSemiAnd +-- > [ "the package " ++ display pkgname ++ " components " +-- > ++ renderListCommaAnd showComponentName components +-- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] +-- +sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] +sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) + . groupBy ((==) `on` key) + . sortBy (compare `on` key) + + +---------------------------------------------------- +-- Renderering for a few project and package types +-- + +renderTargetSelector :: TargetSelector PackageId -> String +renderTargetSelector (TargetPackage _ pkgid Nothing) = + "the package " ++ display pkgid + +renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ display pkgid + +renderTargetSelector (TargetAllPackages Nothing) = + "all the packages in the project" + +renderTargetSelector (TargetAllPackages (Just kfilter)) = + "all the " ++ renderComponentKind Plural kfilter + ++ " in the project" + +renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) = + "the library in the package " ++ display pkgid + +renderTargetSelector (TargetComponent _pkgid cname WholeComponent) = + "the " ++ showComponentName cname + +renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) = + "the file " ++ filename ++ " in the " ++ showComponentName cname + +renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) = + "the module " ++ display modname ++ " in the " ++ showComponentName cname + + +renderOptionalStanza :: Plural -> OptionalStanza -> String +renderOptionalStanza Singular TestStanzas = "test suite" +renderOptionalStanza Plural TestStanzas = "test suites" +renderOptionalStanza Singular BenchStanzas = "benchmark" +renderOptionalStanza Plural BenchStanzas = "benchmarks" + +-- | The optional stanza type (test suite or benchmark), if it is one. +optionalStanza :: ComponentName -> Maybe OptionalStanza +optionalStanza (CTestName _) = Just TestStanzas +optionalStanza (CBenchName _) = Just BenchStanzas +optionalStanza _ = Nothing + + +-- | Does the 'TargetSelector' potentially refer to one package or many? +-- +targetSelectorPluralPkgs :: TargetSelector a -> Plural +targetSelectorPluralPkgs (TargetAllPackages _) = Plural +targetSelectorPluralPkgs (TargetPackage _ _ _) = Singular +targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular + +-- | Does the 'TargetSelector' refer to +targetSelectorRefersToPkgs :: TargetSelector a -> Bool +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetComponent _ _ _) = False + +renderComponentKind :: Plural -> ComponentKind -> String +renderComponentKind Singular ckind = case ckind of + LibKind -> "library" -- internal/sub libs? + FLibKind -> "foreign library" + ExeKind -> "executable" + TestKind -> "test suite" + BenchKind -> "benchmark" +renderComponentKind Plural ckind = case ckind of + LibKind -> "libraries" -- internal/sub libs? + FLibKind -> "foreign libraries" + ExeKind -> "executables" + TestKind -> "test suites" + BenchKind -> "benchmarks" + + +------------------------------------------------------- +-- Renderering error messages for TargetProblemCommon +-- + +renderTargetProblemCommon :: String -> TargetProblemCommon -> String +renderTargetProblemCommon verb (TargetNotInProject pkgname) = + "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly). If you want to add it " + ++ "to the project then edit the cabal.project file." + +renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "package " ++ display pkgid ++ " is not local to the project, and cabal " + ++ "does not currently support building test suites or benchmarks of " + ++ "non-local dependencies. To run test suites or benchmarks from " + ++ "dependencies you can unpack the package locally and adjust the " + ++ "cabal.project file to include that package directory." + +renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " + ++ "marked as 'buildable: False' within the '" ++ display (packageName pkgid) + ++ ".cabal' file (at least for the current configuration). If you believe it " + ++ "should be buildable then check the .cabal file to see if the buildable " + ++ "property is conditional on flags. Alternatively you may simply have to " + ++ "edit the .cabal file to declare it as buildable and fix any resulting " + ++ "build problems." + +renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " + ++ "building " ++ compkinds ++ " has been explicitly disabled in the " + ++ "configuration. You can adjust this configuration in the " + ++ "cabal.project{.local} file either for all packages in the project or on " + ++ "a per-package basis. Note that if you do not explicitly disable " + ++ compkinds ++ " then the solver will merely try to make a plan with " + ++ "them available, so you may wish to explicitly enable them which will " + ++ "require the solver to find a plan with them available or to fail with an " + ++ "explanation." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "solver did not find a plan that included the " ++ compkinds + ++ " for " ++ display pkgid ++ ". It is probably worth trying again with " + ++ compkinds ++ "explicitly enabled in the configuration in the " + ++ "cabal.project{.local} file. This will ask the solver to find a plan with " + ++ "the " ++ compkinds ++ " available. It will either fail with an " + ++ "explanation or find a different plan that uses different versions of some " + ++ "other packages. Use the '--dry-run' flag to see package versions and " + ++ "check that you are happy with the choices." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) = + "Internal error when trying to " ++ verb ++ " the package " + ++ display pkgid ++ ". The package is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + +renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) = + "Internal error when trying to " ++ verb ++ " the " + ++ showComponentName cname ++ " from the package " ++ display pkgid + ++ ". The package,component pair is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoneEnabled :: String + -> TargetSelector PackageId + -> [AvailableTarget ()] + -> String +renderTargetProblemNoneEnabled verb targetSelector targets = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because none of the components are available to build: " + ++ renderListSemiAnd + [ case (status, mstanza) of + (TargetDisabledByUser, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ " not available because building " + ++ renderOptionalStanza Plural stanza + ++ " has been disabled in the configuration" + (TargetDisabledBySolver, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ "not available because the solver did not find a plan that " + ++ "included the " ++ renderOptionalStanza Plural stanza + (TargetNotBuildable, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are all " + ++ "marked as 'buildable: False'" + (TargetNotLocal, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " cannot be built because cabal does not currently support " + ++ "building test suites or benchmarks of non-local dependencies" + (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " will not be built because " ++ renderOptionalStanza Plural stanza + ++ " are not built by default in the current configuration (but you " + ++ "can still build them specifically)" --TODO: say how + _ -> error $ "renderBuildTargetProblem: unexpected status " + ++ show (status, mstanza) + | ((status, mstanza), targets') <- sortGroupOn groupingKey targets + ] + where + groupingKey t = + ( availableTargetStatus t + , case availableTargetStatus t of + TargetNotBuildable -> Nothing + TargetNotLocal -> Nothing + _ -> optionalStanza (availableTargetComponentName t) + ) + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoTargets@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoTargets :: String -> TargetSelector PackageId -> String +renderTargetProblemNoTargets verb targetSelector = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because " ++ reason targetSelector ++ ". " + ++ "Check the .cabal " + ++ plural (targetSelectorPluralPkgs targetSelector) + "file for the package and make sure that it properly declares " + "files for the packages and make sure that they properly declare " + ++ "the components that you expect." + where + reason (TargetPackage _ _ Nothing) = + "it does not contain any components at all" + reason (TargetPackage _ _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetAllPackages Nothing) = + "none of them contain any components at all" + reason (TargetAllPackages (Just kfilter)) = + "none of the packages contain any " + ++ renderComponentKind Plural kfilter + reason ts@TargetComponent{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + +----------------------------------------------------------- +-- Renderering error messages for CannotPruneDependencies +-- + +renderCannotPruneDependencies :: CannotPruneDependencies -> String +renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ display pkgid ++ " is " + _ -> "the packages " + ++ renderListCommaAnd (map display pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + -- throw away the details and just list the deps that are needed + pkgids :: [PackageId] + pkgids = nub . map packageId . concatMap snd $ brokenPackages + +{- + ++ "Syntax:\n" + ++ " - build [package]\n" + ++ " - build [package:]component\n" + ++ " - build [package:][component:]module\n" + ++ " - build [package:][component:]file\n" + ++ " where\n" + ++ " package is a package name, package dir or .cabal file\n\n" + ++ "Examples:\n" + ++ " - build foo -- package name\n" + ++ " - build tests -- component name\n" + ++ " (name of library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n\n" + ++ "An ambigious target can be qualified by package, component\n" + ++ "and/or component kind (lib|exe|test|bench|flib)\n" + ++ " - build foo:tests -- component qualified by package\n" + ++ " - build tests:Data.Foo -- module qualified by component\n" + ++ " - build lib:foo -- component qualified by kind" +-} diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdFreeze.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-} + +-- | cabal-install CLI command: freeze +-- +module Distribution.Client.CmdFreeze ( + freezeCommand, + freezeAction, + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , writeProjectLocalFreezeConfig ) +import Distribution.Client.Targets + ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(distProjectFile) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + + +import Distribution.Package + ( PackageName, packageName, packageVersion ) +import Distribution.Version + ( VersionRange, thisVersion + , unionVersionRanges, simplifyVersionRange ) +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice ) +import Distribution.Verbosity + ( normal ) + +import Data.Monoid as Monoid +import qualified Data.Map as Map +import Data.Map (Map) +import Control.Monad (unless) + +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Utils + ( wrapText ) +import qualified Distribution.Client.Setup as Client + + +freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +freezeCommand = Client.installCommand { + commandName = "new-freeze", + commandSynopsis = "Freeze dependencies.", + commandUsage = usageAlternatives "new-freeze" [ "[FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "The project configuration is frozen so that it will be reproducible " + ++ "in future.\n\n" + + ++ "The precise dependency configuration for the project is written to " + ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " + ++ "'--project-file' is specified). This file extends the configuration " + ++ "from the 'cabal.project' file and thus is used as the project " + ++ "configuration for all other commands (such as 'new-build', " + ++ "'new-repl' etc).\n\n" + + ++ "The freeze file can be kept in source control. To make small " + ++ "adjustments it may be edited manually, or to make bigger changes " + ++ "you may wish to delete the file and re-freeze. For more control, " + ++ "one approach is to try variations using 'new-build --dry-run' with " + ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " + ++ "a satisfactory solution to freeze it using the 'new-freeze' command " + ++ "with the same set of flags.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-freeze\n" + ++ " Freeze the configuration of the current project\n\n" + ++ " " ++ pname ++ " new-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " Check what a solution with the given constraints would look like\n" + ++ " " ++ pname ++ " new-freeze --constraint=\"aeson < 1\"\n" + ++ " Freeze a solution using the given constraints\n\n" + + ++ "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" + } + +-- | To a first approximation, the @freeze@ command runs the first phase of +-- the @build@ command where we bring the install plan up to date, and then +-- based on the install plan we write out a @cabal.project.freeze@ config file. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + extraArgs globalFlags = do + + unless (null extraArgs) $ + die' verbosity $ "'freeze' doesn't take any extra arguments: " + ++ unwords extraArgs + + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } <- establishProjectBaseContext verbosity cliConfig + + (_, elaboratedPlan, _) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + let freezeConfig = projectFreezeConfig elaboratedPlan + writeProjectLocalFreezeConfig distDirLayout freezeConfig + notice verbosity $ + "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + + + +-- | Given the install plan, produce a config value with constraints that +-- freezes the versions of packages used in the plan. +-- +projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig +projectFreezeConfig elaboratedPlan = + Monoid.mempty { + projectConfigShared = Monoid.mempty { + projectConfigConstraints = + concat (Map.elems (projectFreezeConstraints elaboratedPlan)) + } + } + +-- | Given the install plan, produce solver constraints that will ensure the +-- solver picks the same solution again in future in different environments. +-- +projectFreezeConstraints :: ElaboratedInstallPlan + -> Map PackageName [(UserConstraint, ConstraintSource)] +projectFreezeConstraints plan = + -- + -- TODO: [required eventually] this is currently an underapproximation + -- since the constraints language is not expressive enough to specify the + -- precise solution. See https://github.com/haskell/cabal/issues/3502. + -- + -- For the moment we deal with multiple versions in the solution by using + -- constraints that allow either version. Also, we do not include any + -- /version/ constraints for packages that are local to the project (e.g. + -- if the solution has two instances of Cabal, one from the local project + -- and one pulled in as a setup deps then we exclude all constraints on + -- Cabal, not just the constraint for the local instance since any + -- constraint would apply to both instances). We do however keep flag + -- constraints of local packages. + -- + deleteLocalPackagesVersionConstraints + (Map.unionWith (++) versionConstraints flagConstraints) + where + versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + versionConstraints = + Map.mapWithKey + (\p v -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyVersion v), + ConstraintSourceFreeze)]) + versionRanges + + versionRanges :: Map PackageName VersionRange + versionRanges = + Map.map simplifyVersionRange $ + Map.fromListWith unionVersionRanges $ + [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.PreExisting pkg <- InstallPlan.toList plan + ] + ++ [ (packageName pkg, thisVersion (packageVersion pkg)) + | InstallPlan.Configured pkg <- InstallPlan.toList plan + ] + + flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + flagConstraints = + Map.mapWithKey + (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), + ConstraintSourceFreeze)]) + flagAssignments + + flagAssignments :: Map PackageName FlagAssignment + flagAssignments = + Map.fromList + [ (pkgname, flags) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , let flags = elabFlagAssignment elab + pkgname = packageName elab + , not (null flags) ] + + -- As described above, remove the version constraints on local packages, + -- but leave any flag constraints. + deleteLocalPackagesVersionConstraints + :: Map PackageName [(UserConstraint, ConstraintSource)] + -> Map PackageName [(UserConstraint, ConstraintSource)] + deleteLocalPackagesVersionConstraints = +#if MIN_VERSION_containers(0,5,0) + Map.mergeWithKey + (\_pkgname () constraints -> + case filter (not . isVersionConstraint . fst) constraints of + [] -> Nothing + constraints' -> Just constraints') + (const Map.empty) id + localPackages +#else + Map.mapMaybeWithKey + (\pkgname constraints -> + if pkgname `Map.member` localPackages + then case filter (not . isVersionConstraint . fst) constraints of + [] -> Nothing + constraints' -> Just constraints' + else Just constraints) +#endif + + isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True + isVersionConstraint _ = False + + localPackages :: Map PackageName () + localPackages = + Map.fromList + [ (packageName elab, ()) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , elabLocalToProject elab + ] + diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdHaddock.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: haddock +-- +module Distribution.Client.CmdHaddock ( + -- * The @haddock@ CLI and action + haddockCommand, + haddockAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags(..), fromFlagOrDefault, fromFlag ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import Control.Monad (when) + + +haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags + ,HaddockFlags) +haddockCommand = Client.installCommand { + commandName = "new-haddock", + commandSynopsis = "Build Haddock documentation", + commandUsage = usageAlternatives "new-haddock" [ "[FLAGS] TARGET" ], + commandDescription = Just $ \_ -> wrapText $ + "Build Haddock documentation for the specified packages within the " + ++ "project.\n\n" + + ++ "Any package in the project can be specified. If no package is " + ++ "specified, the default is to build the documentation for the package " + ++ "in the current directory. The default behaviour is to build " + ++ "documentation for the exposed modules of the library component (if " + ++ "any). This can be changed with the '--internal', '--executables', " + ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" + + ++ "Currently, documentation for dependencies is NOT built. This " + ++ "behavior may change in future.\n\n" + + ++ "Additional configuration flags can be specified on the command line " + ++ "and these extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-haddock pkgname" + ++ " Build documentation for the package named pkgname\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + --TODO: [nice to have] support haddock on specific components, not just + -- whole packages and the silly --executables etc modifiers. + +-- | The @haddock@ command is TODO. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity + "The haddock command does not support '--only-dependencies'." + + -- When we interpret the targets on the command line, interpret them as + -- haddock targets + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + (selectPackageTargets haddockFlags) + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return elaboratedPlan' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @haddock@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @haddock@ command we select all buildable libraries. Additionally, +-- depending on the @--executables@ flag we also select all the buildable exes. +-- We do similarly for test-suites, benchmarks and foreign libs. +-- +selectPackageTargets :: HaddockFlags -> TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets haddockFlags targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail (map disableNotRequested targets) + targetsBuildable = selectBuildableTargets (map disableNotRequested targets) + + -- When there's a target filter like "pkg:exes" then we do select exes, + -- but if it's just a target like "pkg" then we don't build docs for exes + -- unless they are requested by default (i.e. by using --executables) + disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) + | not (isRequested targetSelector (componentKind cname)) + = t { availableTargetStatus = TargetDisabledByUser } + disableNotRequested t = t + + isRequested (TargetPackage _ _ (Just _)) _ = True + isRequested (TargetAllPackages (Just _)) _ = True + isRequested _ LibKind = True +-- isRequested _ SubLibKind = True --TODO: what about sublibs? + isRequested _ FLibKind = fromFlag (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlag (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlag (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlag (haddockBenchmarks haddockFlags) + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @haddock@ command we just need the basic checks on being buildable +-- etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @haddock@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build documentation for" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build documentation for" targetSelector targets + +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build documentation for" targetSelector diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -1,32 +1,81 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: repl -- module Distribution.Client.CmdRepl ( + -- * The @repl@ CLI and action + replCommand, replAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget ) where import Distribution.Client.ProjectOrchestration - ( PreBuildHooks(..), runProjectPreBuildPhase, selectTargets - , ProjectBuildContext(..), runProjectBuildPhase - , printPlan, reportBuildFailures ) -import Distribution.Client.ProjectConfig - ( BuildTimeSettings(..) ) -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) -import Distribution.Client.BuildTarget - ( readUserBuildTargets ) +import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Package + ( packageName ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Text + ( display ) import Distribution.Verbosity - ( normal ) + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', ordNub ) -import Control.Monad (unless) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad (when) +replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +replCommand = Client.installCommand { + commandName = "new-repl", + commandSynopsis = "Open an interactive session for the given component.", + commandUsage = usageAlternatives "new-repl" [ "[TARGET] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'new-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples, open an interactive session:\n" + ++ " " ++ pname ++ " new-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " ++ pname ++ " new-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " ++ pname ++ " new-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " new-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " ++ pname ++ " new-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- repl target and then executes the plan. @@ -39,36 +88,205 @@ -- "Distribution.Client.ProjectOrchestration" -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags) + -> [String] -> GlobalFlags -> IO () +replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig - buildCtx@ProjectBuildContext{buildSettings} <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \_ _ _ -> return (), - hookSelectPlanSubset = selectReplTargets userTargets - } + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings - printPlan verbosity buildCtx + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - unless (buildSettingDryRun buildSettings) $ do - plan <- runProjectBuildPhase - verbosity - buildCtx - reportBuildFailures plan + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ "The repl command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'repl'." + + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1) $ + reportTargetProblems verbosity + [TargetProblemMultipleTargets targets] + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + return elaboratedPlan' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags - -- When we interpret the targets on the command line, interpret them as - -- repl targets (as opposed to say build or haddock targets). - selectReplTargets = - selectTargets - ReplDefaultComponent - ReplSpecificComponent +-- | This defines what a 'TargetSelector' means for the @repl@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For repl we select: +-- +-- * the library if there is only one and it's buildable; or +-- +-- * the exe if there is only one and it's buildable; or +-- +-- * any other buildable component. +-- +-- Fail if there are no buildable lib\/exe components, or if there are +-- multiple libs or exes. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable + = Right [target] + + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsLibsBuildable') + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') + + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable + = Right [target] + + -- but fail if there are multiple such targets + | not (null targetsBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsBuildable') + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + (targetsLibsBuildable, + targetsLibsBuildable') = selectBuildableTargets' + . filterTargetsKind LibKind + $ targets + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + (targetsBuildable, + targetsBuildable') = selectBuildableTargetsWith' + (isRequested targetSelector) targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested _ _ = True + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @repl@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "open a repl for" problem + +renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " ++ renderComponentKind Plural ckind ++ " " ++ + renderListCommaAnd + [ maybe (display pkgname) display (componentNameString cname) + | t <- ts + , let cname = availableTargetComponentName t + pkgname = packageName (availableTargetPackageId t) + ] + | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets + ] + ++ ".\n\n" ++ explanationSingleComponentLimitation + where + availableTargetComponentKind = componentKind + . availableTargetComponentName + +renderTargetProblem (TargetProblemMultipleTargets selectorMap) = + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different components." + ++ ".\n\n" ++ explanationSingleComponentLimitation + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "open a repl for" targetSelector targets + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "open a repl for" targetSelector + + +explanationSingleComponentLimitation :: String +explanationSingleComponentLimitation = + "The reason for this limitation is that current versions of ghci do not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload." diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdRun.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: run +-- +module Distribution.Client.CmdRun ( + -- * The @run@ CLI and action + runCommand, + runAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', ordNub ) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad (when) + + +runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +runCommand = Client.installCommand { + commandName = "new-run", + commandSynopsis = "Run an executable.", + commandUsage = usageAlternatives "new-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], + commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable, first ensuring it is up to date.\n\n" + + ++ "Any executable in any package in the project can be specified. " + ++ "A package can be specified if contains just one executable. " + ++ "The default is to use the package in the current directory if it " + ++ "contains just one executable.\n\n" + + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-run\n" + ++ " Run the executable in the package in the current directory\n" + ++ " " ++ pname ++ " new-run foo-tool\n" + ++ " Run the named executable (in any package in the project)\n" + ++ " " ++ pname ++ " new-run pkgfoo:foo-tool\n" + ++ " Run the executable 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The run command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'run'." + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1) $ + reportTargetProblems verbosity + [TargetProblemMultipleTargets targets] + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return elaboratedPlan' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @run@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @run@ command we select the exe if there is only one and it's +-- buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExes) + = Left (TargetProblemNoneEnabled targetSelector targetsExes) + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoExes targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + + targetsExes = forgetTargetsDetail + . filterTargetsKind ExeKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CExeName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotExe pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no executables + | TargetProblemNoExes (TargetSelector PackageId) + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | The 'TargetSelector' refers to a component that is not an executable + | TargetProblemComponentNotExe PackageId ComponentName + + -- | Asking to run an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "run" targetSelector targets + +renderTargetProblem (TargetProblemNoExes targetSelector) = + "Cannot run the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "run" targetSelector + where + targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter + targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter + targetSelectorFilter (TargetComponent _ _ _) = Nothing + + +renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The run command is for running a single executable at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes the executables " + ++ renderListCommaAnd + [ display name + | cname@CExeName{} <- map availableTargetComponentName targets + , let Just name = componentNameString cname + ] + ++ "." + +renderTargetProblem (TargetProblemMultipleTargets selectorMap) = + "The run command is for running a single executable at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different executables." + +renderTargetProblem (TargetProblemComponentNotExe pkgid cname) = + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The run command can only run an executable as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget + diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdTest.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: test +-- +module Distribution.Client.CmdTest ( + -- * The @test@ CLI and action + testCommand, + testAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import Control.Monad (when) + + +testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +testCommand = Client.installCommand { + commandName = "new-test", + commandSynopsis = "Run test-suites", + commandUsage = usageAlternatives "new-test" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified test-suites, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any test-suite in any package in the project can be specified. " + ++ "A package can be specified in which case all the test-suites in the " + ++ "package are run. The default is to run all the test-suites in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-test\n" + ++ " Run all the test-suites in the package in the current directory\n" + ++ " " ++ pname ++ " new-test pkgname\n" + ++ " Run all the test-suites in the package named pkgname\n" + ++ " " ++ pname ++ " new-test cname\n" + ++ " Run the test-suite named cname\n" + ++ " " ++ pname ++ " new-test cname --enable-coverage\n" + ++ " Run the test-suite built with code coverage (including local libs used)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @test@ command is very much like @build@. It brings the install plan +-- up to date, selects that part of the plan needed by the given or implicit +-- test target(s) and then executes the plan. +-- +-- Compared to @build@ the difference is that there's also test targets +-- which are ephemeral. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The test command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'test'." + + -- Interpret the targets on the command line as test targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return elaboratedPlan' + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @test@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @test@ command we select all buildable test-suites, +-- or fail if there are no test-suites or no buildable test-suites. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable test-suite targets then we select those + | not (null targetsTestsBuildable) + = Right targetsTestsBuildable + + -- If there are test-suites but none are buildable then we report those + | not (null targetsTests) + = Left (TargetProblemNoneEnabled targetSelector targetsTests) + + -- If there are no test-suite but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoTests targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsTestsBuildable = selectBuildableTargets + . filterTargetsKind TestKind + $ targets + + targetsTests = forgetTargetsDetail + . filterTargetsKind TestKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @test@ command we just need to check it is a test-suite, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CTestName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotTest pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @test@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no test-suites + | TargetProblemNoTests (TargetSelector PackageId) + + -- | The 'TargetSelector' refers to a component that is not a test-suite + | TargetProblemComponentNotTest PackageId ComponentName + + -- | Asking to test an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "test" targetSelector targets + +renderTargetProblem (TargetProblemNoTests targetSelector) = + "Cannot run tests for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any test suites." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= TestKind + -> "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "test" targetSelector + where + targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter + targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter + targetSelectorFilter (TargetComponent _ _ _) = Nothing + +renderTargetProblem (TargetProblemComponentNotTest pkgid cname) = + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The test command can only run test suites as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/Distribution/Client/Compat/FileLock.hsc b/Distribution/Client/Compat/FileLock.hsc new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/FileLock.hsc @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum +-- required version. Though note that the locking functionality is not in +-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. +module Distribution.Client.Compat.FileLock ( + FileLockingNotSupported(..) + , LockMode(..) + , hLock + , hTryLock + ) where + +#if MIN_VERSION_base(4,10,0) + +import GHC.IO.Handle.Lock + +#else + +-- The remainder of this file is a modified copy +-- of GHC.IO.Handle.Lock from ghc-8.2.x +-- +-- The modifications were just to the imports and the CPP, since we do not have +-- access to the HAVE_FLOCK from the ./configure script. We approximate the +-- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the +-- only known major Unix platform lacking flock(). + +import Control.Exception (Exception) +import Data.Typeable + +#if defined(solaris2_HOST_OS) + +import Control.Exception (throwIO) +import System.IO (Handle) + +#else + +import Data.Bits +import Data.Function +import Control.Concurrent.MVar + +import Foreign.C.Error +import Foreign.C.Types + +import GHC.IO.Handle.Types +import GHC.IO.FD +import GHC.IO.Exception + +#if defined(mingw32_HOST_OS) + +#if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +#elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +#else +# error Unknown mingw32 arch +#endif + +#include + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Ptr +import GHC.Windows + +#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ + +#include + +#endif /* !defined(mingw32_HOST_OS) */ + +#endif /* !defined(solaris2_HOST_OS) */ + +#endif /* MIN_VERSION_base */ + + +#if !(MIN_VERSION_base(4,10,0)) + +-- | Exception thrown by 'hLock' on non-Windows platforms that don't support +-- 'flock'. +data FileLockingNotSupported = FileLockingNotSupported + deriving (Typeable, Show) + +instance Exception FileLockingNotSupported + +-- | Indicates a mode in which a file should be locked. +data LockMode = SharedLock | ExclusiveLock + +-- | If a 'Handle' references a file descriptor, attempt to lock contents of the +-- underlying file in appropriate mode. If the file is already locked in +-- incompatible mode, this function blocks until the lock is established. The +-- lock is automatically released upon closing a 'Handle'. +-- +-- Things to be aware of: +-- +-- 1) This function may block inside a C call. If it does, in order to be able +-- to interrupt it with asynchronous exceptions and/or for other threads to +-- continue working, you MUST use threaded version of the runtime system. +-- +-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, +-- hence all of their caveats also apply here. +-- +-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this +-- function throws 'FileLockingNotImplemented'. We deliberately choose to not +-- provide fcntl based locking instead because of its broken semantics. +-- +-- @since 4.10.0.0 +hLock :: Handle -> LockMode -> IO () +hLock h mode = lockImpl h "hLock" mode True >> return () + +-- | Non-blocking version of 'hLock'. +-- +-- @since 4.10.0.0 +hTryLock :: Handle -> LockMode -> IO Bool +hTryLock h mode = lockImpl h "hTryLock" mode False + +---------------------------------------- + +#if defined(solaris2_HOST_OS) + +-- | No-op implementation. +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl _ _ _ _ = throwIO FileLockingNotSupported + +#else /* !defined(solaris2_HOST_OS) */ + +#if defined(mingw32_HOST_OS) + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd + allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do + fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0 + let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY}) + -- We want to lock the whole file without looking up its size to be + -- consistent with what flock does. According to documentation of LockFileEx + -- "locking a region that goes beyond the current end-of-file position is + -- not an error", however e.g. Windows 10 doesn't accept maximum possible + -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by + -- trying 2^32-1. + fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case + True -> return True + False -> getLastError >>= \err -> if + | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False + | err == #{const ERROR_OPERATION_ABORTED} -> retry + | otherwise -> failWith ctx err + where + sizeof_OVERLAPPED = #{size OVERLAPPED} + + cmode = case mode of + SharedLock -> 0 + ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} + +-- https://msdn.microsoft.com/en-us/library/aa297958.aspx +foreign import ccall unsafe "_get_osfhandle" + c_get_osfhandle :: CInt -> IO HANDLE + +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx +foreign import WINDOWS_CCONV interruptible "LockFileEx" + c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL + +#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) + fix $ \retry -> c_flock fd flags >>= \case + 0 -> return True + _ -> getErrno >>= \errno -> if + | not block && errno == eWOULDBLOCK -> return False + | errno == eINTR -> retry + | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + where + cmode = case mode of + SharedLock -> #{const LOCK_SH} + ExclusiveLock -> #{const LOCK_EX} + +foreign import ccall interruptible "flock" + c_flock :: CInt -> CInt -> IO CInt + +#endif /* !defined(mingw32_HOST_OS) */ + +-- | Turn an existing Handle into a file descriptor. This function throws an +-- IOError if the Handle does not reference a file descriptor. +handleToFd :: Handle -> IO FD +handleToFd h = case h of + FileHandle _ mv -> do + Handle__{haDevice = dev} <- readMVar mv + case cast dev of + Just fd -> return fd + Nothing -> throwErr "not a file descriptor" + DuplexHandle{} -> throwErr "not a file handle" + where + throwErr msg = ioException $ IOError (Just h) + InappropriateType "handleToFd" msg Nothing Nothing + +#endif /* defined(solaris2_HOST_OS) */ + +#endif /* MIN_VERSION_base */ diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Prelude.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} + +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatiblity layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Client.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , Prelude.IO + , readMaybe + ) where + +import Prelude (IO) +import Distribution.Compat.Prelude.Internal hiding (IO) + +#if MIN_VERSION_base(4,6,0) +import Text.Read + ( readMaybe ) +#endif + +#if !MIN_VERSION_base(4,6,0) +-- | An implementation of readMaybe, for compatibility with older base versions. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing +#endif diff --git a/Distribution/Client/Compat/Process.hs b/Distribution/Client/Compat/Process.hs --- a/Distribution/Client/Compat/Process.hs +++ b/Distribution/Client/Compat/Process.hs @@ -24,7 +24,7 @@ import Control.Exception (catch, throw) import System.Exit (ExitCode (ExitFailure)) -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (isDoesNotExistError, isPermissionError) import qualified System.Process as P -- | @readProcessWithExitCode@ creates an external process, reads its @@ -38,11 +38,12 @@ -- The version from @System.Process@ behaves inconsistently across -- platforms when an executable with the given name is not found: in -- some cases it returns an @ExitFailure@, in others it throws an --- exception. This variant catches \"does not exist\" exceptions and --- turns them into @ExitFailure@s. +-- exception. This variant catches \"does not exist\" and +-- \"permission denied\" exceptions and turns them into +-- @ExitFailure@s. readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) readProcessWithExitCode cmd args input = P.readProcessWithExitCode cmd args input - `catch` \e -> if isDoesNotExistError e + `catch` \e -> if isDoesNotExistError e || isPermissionError e then return (ExitFailure 127, "", "") else throw e diff --git a/Distribution/Client/Compat/Time.hs b/Distribution/Client/Compat/Time.hs deleted file mode 100644 --- a/Distribution/Client/Compat/Time.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} -module Distribution.Client.Compat.Time - ( ModTime(..) -- Needed for testing - , getModTime, getFileAge, getCurTime - , posixSecondsToModTime ) - where - -import Control.Arrow ( first ) -import Data.Int ( Int64 ) -import Data.Word ( Word64 ) -import System.Directory ( getModificationTime ) - -import Distribution.Compat.Binary ( Binary ) - -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) -#if MIN_VERSION_directory(1,2,0) -import Data.Time.Clock.POSIX ( posixDayLength ) -import Data.Time ( diffUTCTime, getCurrentTime ) -#else -import System.Time ( getClockTime, diffClockTimes - , normalizeTimeDiff, tdDay, tdHour ) -#endif - -#if defined mingw32_HOST_OS - -import Data.Bits ((.|.), unsafeShiftL) -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize) -#else -import Data.Bits (bitSize) -#endif - -import Data.Int ( Int32 ) -import Foreign ( allocaBytes, peekByteOff ) -import System.IO.Error ( mkIOError, doesNotExistErrorType ) -import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) - -#else - -import System.Posix.Files ( FileStatus, getFileStatus ) - -#if MIN_VERSION_unix(2,6,0) -import System.Posix.Files ( modificationTimeHiRes ) -#else -import System.Posix.Files ( modificationTime ) -#endif - -#endif - --- | An opaque type representing a file's modification time, represented --- internally as a 64-bit unsigned integer in the Windows UTC format. -newtype ModTime = ModTime Word64 - deriving (Binary, Bounded, Eq, Ord) - -instance Show ModTime where - show (ModTime x) = show x - -instance Read ModTime where - readsPrec p str = map (first ModTime) (readsPrec p str) - --- | Return modification time of the given file. Works around the low clock --- resolution problem that 'getModificationTime' has on GHC < 7.8. --- --- This is a modified version of the code originally written for Shake by Neil --- Mitchell. See module Development.Shake.FileInfo. -getModTime :: FilePath -> IO ModTime - -#if defined mingw32_HOST_OS - --- Directly against the Win32 API. -getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do - res <- getFileAttributesEx path info - if not res - then do - let err = mkIOError doesNotExistErrorType - "Distribution.Client.Compat.Time.getModTime" - Nothing (Just path) - ioError err - else do - dwLow <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime - dwHigh <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime -#if MIN_VERSION_base(4,7,0) - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) -#else - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) -#endif - return $! ModTime (qwTime :: Word64) - -#ifdef x86_64_HOST_ARCH -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV "windows.h GetFileAttributesExW" - c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL - -getFileAttributesEx :: String -> LPVOID -> IO BOOL -getFileAttributesEx path lpFileInformation = - withTString path $ \c_path -> - c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation - -getFileExInfoStandard :: Int32 -getFileExInfoStandard = 0 - -size_WIN32_FILE_ATTRIBUTE_DATA :: Int -size_WIN32_FILE_ATTRIBUTE_DATA = 36 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24 - -#else - --- Directly against the unix library. -getModTime path = do - st <- getFileStatus path - return $! (extractFileTime st) - -extractFileTime :: FileStatus -> ModTime -#if MIN_VERSION_unix(2,6,0) -extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) -#else -extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $ - modificationTime x -#endif - -#endif - -windowsTick, secToUnixEpoch :: Word64 -windowsTick = 10000000 -secToUnixEpoch = 11644473600 - --- | Convert POSIX seconds to ModTime. -posixSecondsToModTime :: Int64 -> ModTime -posixSecondsToModTime s = - ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick - --- | Convert 'POSIXTime' to 'ModTime'. -posixTimeToModTime :: POSIXTime -> ModTime -posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision - + (secToUnixEpoch * windowsTick) - --- | Return age of given file in days. -getFileAge :: FilePath -> IO Double -getFileAge file = do - t0 <- getModificationTime file -#if MIN_VERSION_directory(1,2,0) - t1 <- getCurrentTime - return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength -#else - t1 <- getClockTime - let dt = normalizeTimeDiff (t1 `diffClockTimes` t0) - return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0 -#endif - --- | Return the current time as 'ModTime'. -getCurTime :: IO ModTime -getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. diff --git a/Distribution/Client/ComponentDeps.hs b/Distribution/Client/ComponentDeps.hs deleted file mode 100644 --- a/Distribution/Client/ComponentDeps.hs +++ /dev/null @@ -1,161 +0,0 @@ --- | Fine-grained package dependencies --- --- Like many others, this module is meant to be "double-imported": --- --- > import Distribution.Client.ComponentDeps ( --- > Component --- > , ComponentDep --- > , ComponentDeps --- > ) --- > import qualified Distribution.Client.ComponentDeps as CD -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Client.ComponentDeps ( - -- * Fine-grained package dependencies - Component(..) - , ComponentDep - , ComponentDeps -- opaque - -- ** Constructing ComponentDeps - , empty - , fromList - , singleton - , insert - , filterDeps - , fromLibraryDeps - , fromSetupDeps - , fromInstalled - -- ** Deconstructing ComponentDeps - , toList - , flatDeps - , nonSetupDeps - , libraryDeps - , setupDeps - , select - ) where - -import Data.Map (Map) -import qualified Data.Map as Map -import Distribution.Compat.Binary (Binary) -import Distribution.Compat.Semigroup (Semigroup((<>))) -import GHC.Generics -import Data.Foldable (fold) - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable(foldMap)) -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) -#endif - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - --- | Component of a package. -data Component = - ComponentLib - | ComponentExe String - | ComponentTest String - | ComponentBench String - | ComponentSetup - deriving (Show, Eq, Ord, Generic) - -instance Binary Component - --- | Dependency for a single component. -type ComponentDep a = (Component, a) - --- | Fine-grained dependencies for a package. --- --- Typically used as @ComponentDeps [Dependency]@, to represent the list of --- dependencies for each named component within a package. --- -newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } - deriving (Show, Functor, Eq, Ord, Generic) - -instance Semigroup a => Monoid (ComponentDeps a) where - mempty = ComponentDeps Map.empty - mappend = (<>) - -instance Semigroup a => Semigroup (ComponentDeps a) where - ComponentDeps d <> ComponentDeps d' = - ComponentDeps (Map.unionWith (<>) d d') - -instance Foldable ComponentDeps where - foldMap f = foldMap f . unComponentDeps - -instance Traversable ComponentDeps where - traverse f = fmap ComponentDeps . traverse f . unComponentDeps - -instance Binary a => Binary (ComponentDeps a) - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -empty :: ComponentDeps a -empty = ComponentDeps $ Map.empty - -fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a -fromList = ComponentDeps . Map.fromListWith mappend - -singleton :: Component -> a -> ComponentDeps a -singleton comp = ComponentDeps . Map.singleton comp - -insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a -insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps - where - aux Nothing = Just a - aux (Just a') = Just $ a `mappend` a' - --- | Keep only selected components (and their associated deps info). -filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a -filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps - --- | ComponentDeps containing library dependencies only -fromLibraryDeps :: a -> ComponentDeps a -fromLibraryDeps = singleton ComponentLib - --- | ComponentDeps containing setup dependencies only. -fromSetupDeps :: a -> ComponentDeps a -fromSetupDeps = singleton ComponentSetup - --- | ComponentDeps for installed packages. --- --- We assume that installed packages only record their library dependencies. -fromInstalled :: a -> ComponentDeps a -fromInstalled = fromLibraryDeps - -{------------------------------------------------------------------------------- - Deconstruction --------------------------------------------------------------------------------} - -toList :: ComponentDeps a -> [ComponentDep a] -toList = Map.toList . unComponentDeps - --- | All dependencies of a package. --- --- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more --- obvious than a use of 'fold', and moreover this avoids introducing lots of --- @#ifdef@s for 7.10 just for the use of 'fold'. -flatDeps :: Monoid a => ComponentDeps a -> a -flatDeps = fold - --- | All dependencies except the setup dependencies. --- --- Prior to the introduction of setup dependencies in version 1.24 this --- would have been _all_ dependencies. -nonSetupDeps :: Monoid a => ComponentDeps a -> a -nonSetupDeps = select (/= ComponentSetup) - --- | Library dependencies proper only. -libraryDeps :: Monoid a => ComponentDeps a -> a -libraryDeps = select (== ComponentLib) - --- | Setup dependencies. -setupDeps :: Monoid a => ComponentDeps a -> a -setupDeps = select (== ComponentSetup) - --- | Select dependencies satisfying a given predicate. -select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a -select p = foldMap snd . filter (p . fst) . toList diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -48,8 +48,6 @@ ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) -import Distribution.Client.Dependency.Types - ( ConstraintSource(..) ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, defaultGlobalFlags , ConfigExFlags(..), configureExOptions, defaultConfigExFlags @@ -64,10 +62,10 @@ ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags - , AllowNewer(..) + , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , HaddockFlags(..), haddockOptions, defaultHaddockFlags , installDirsOptions, optionDistPref - , programConfigurationPaths', programConfigurationOptions + , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs @@ -86,19 +84,21 @@ import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text - ( Text(..) ) + ( Text(..), display ) import Distribution.Simple.Command ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) , viewAsFieldDescr ) import Distribution.Simple.Program - ( defaultProgramConfiguration ) + ( defaultProgramDb ) import Distribution.Simple.Utils - ( die, notice, warn, lowercase, cabalVersion ) + ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity ( Verbosity, normal ) +import Distribution.Solver.Types.ConstraintSource + import Data.List ( partition, find, foldl' ) import Data.Maybe @@ -227,7 +227,8 @@ globalRequireSandbox = combine globalRequireSandbox, globalIgnoreSandbox = combine globalIgnoreSandbox, globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport + globalHttpTransport = combine globalHttpTransport, + globalNix = combine globalNix } where combine = combine' savedGlobalFlags @@ -239,37 +240,45 @@ installDryRun = combine installDryRun, installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, + installCountConflicts = combine installCountConflicts, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, + installAllowBootLibInstalls = combine installAllowBootLibInstalls, installReinstall = combine installReinstall, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, installUpgradeDeps = combine installUpgradeDeps, installOnly = combine installOnly, installOnlyDeps = combine installOnlyDeps, + installIndexState = combine installIndexState, installRootCmd = combine installRootCmd, installSummaryFile = lastNonEmptyNL installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, + installPerComponent = combine installPerComponent, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, + installKeepGoing = combine installKeepGoing, installRunTests = combine installRunTests, - installOfflineMode = combine installOfflineMode + installOfflineMode = combine installOfflineMode, + installProjectFileName = combine installProjectFileName } where combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags combinedSavedConfigureFlags = ConfigFlags { + configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, -- TODO: NubListify configProgramPaths = lastNonEmpty configProgramPaths, -- TODO: NubListify configProgramArgs = lastNonEmpty configProgramArgs, configProgramPathExtra = lastNonEmptyNL configProgramPathExtra, + configInstantiateWith = lastNonEmpty configInstantiateWith, configHcFlavor = combine configHcFlavor, configHcPath = combine configHcPath, configHcPkg = combine configHcPkg, @@ -298,8 +307,11 @@ configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, -- TODO: NubListify configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, + configDeterministic = combine configDeterministic, configIPID = combine configIPID, + configCID = combine configCID, configDistPref = combine configDistPref, + configCabalFilePath = combine configCabalFilePath, configVerbosity = combine configVerbosity, configUserInstall = combine configUserInstall, -- TODO: NubListify @@ -321,6 +333,8 @@ configExactConfiguration = combine configExactConfiguration, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, + configAllowOlder = combineMonoid savedConfigureFlags + configAllowOlder, configAllowNewer = combineMonoid savedConfigureFlags configAllowNewer } @@ -350,7 +364,7 @@ `mappend` savedGlobalInstallDirs b combinedSavedUploadFlags = UploadFlags { - uploadCheck = combine uploadCheck, + uploadCandidate = combine uploadCandidate, uploadDoc = combine uploadDoc, uploadUsername = combine uploadUsername, uploadPassword = combine uploadPassword, @@ -380,6 +394,7 @@ haddockExecutables = combine haddockExecutables, haddockTestSuites = combine haddockTestSuites, haddockBenchmarks = combine haddockBenchmarks, + haddockForeignLibs = combine haddockForeignLibs, haddockInternal = combine haddockInternal, haddockCss = combine haddockCss, haddockHscolour = combine haddockHscolour, @@ -525,13 +540,9 @@ remoteRepoKeyThreshold = 0 } | secure /= Just False = r { - --TODO: When we want to switch us from using opt-in to opt-out - -- security for the central hackage server, uncomment the - -- following line. That will cause the default (of unspecified) - -- to get interpreted as if it were "secure: True". For the - -- moment it means the keys get added but you have to manually - -- set "secure: True" to opt-in. - --remoteRepoSecure = Just True, + -- Use hackage-security by default unless you opt-out with + -- secure: False + remoteRepoSecure = Just True, remoteRepoRootKeys = defaultHackageRemoteRepoKeys, remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold } @@ -605,7 +616,7 @@ return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ + die' verbosity $ "Error parsing config file " ++ configFile ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -664,15 +675,17 @@ where explanation = unlines ["-- This is the configuration file for the 'cabal' command line tool." - ,"" + ,"--" ,"-- The available configuration options are listed below." ,"-- Some of them have default values listed." - ,"" + ,"--" ,"-- Lines (like this one) beginning with '--' are comments." ,"-- Be careful with spaces and indentation because they are" ,"-- used to indicate layout for nested sections." - ,"" - ,"-- Cabal library version: " ++ showVersion cabalVersion + ,"--" + ,"-- This config file was generated using the following versions" + ,"-- of Cabal and cabal-install:" + ,"-- Cabal library version: " ++ Text.display cabalVersion ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version ,"","" ] @@ -686,21 +699,38 @@ commentSavedConfig = do userInstallDirs <- defaultInstallDirs defaultCompiler True True globalInstallDirs <- defaultInstallDirs defaultCompiler False True - return SavedConfig { - savedGlobalFlags = defaultGlobalFlags, - savedInstallFlags = defaultInstallFlags, - savedConfigureExFlags = defaultConfigExFlags, - savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { - configUserInstall = toFlag defaultUserInstall, - configAllowNewer = Just AllowNewerNone - }, - savedUserInstallDirs = fmap toFlag userInstallDirs, - savedGlobalInstallDirs = fmap toFlag globalInstallDirs, - savedUploadFlags = commandDefaultFlags uploadCommand, - savedReportFlags = commandDefaultFlags reportCommand, - savedHaddockFlags = defaultHaddockFlags - } + let conf0 = mempty { + savedGlobalFlags = defaultGlobalFlags { + globalRemoteRepos = toNubList [defaultRemoteRepo] + }, + savedInstallFlags = defaultInstallFlags, + savedConfigureExFlags = defaultConfigExFlags, + savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { + configUserInstall = toFlag defaultUserInstall, + configAllowNewer = Just (AllowNewer RelaxDepsNone), + configAllowOlder = Just (AllowOlder RelaxDepsNone) + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand, + savedReportFlags = commandDefaultFlags reportCommand, + savedHaddockFlags = defaultHaddockFlags + } + conf1 <- extendToEffectiveConfig conf0 + let globalFlagsConf1 = savedGlobalFlags conf1 + conf2 = conf1 { + savedGlobalFlags = globalFlagsConf1 { + globalRemoteRepos = overNubList (map removeRootKeys) + (globalRemoteRepos globalFlagsConf1) + } + } + return conf2 + where + -- Most people don't want to see default root keys, so don't print them. + removeRootKeys :: RemoteRepo -> RemoteRepo + removeRootKeys r = r { remoteRepoRootKeys = [] } + -- | All config file fields. -- configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig] @@ -721,17 +751,15 @@ [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) configHcFlavor (\v flags -> flags { configHcFlavor = v }) - ,let showAllowNewer Nothing = mempty - showAllowNewer (Just AllowNewerNone) = Disp.text "False" - showAllowNewer (Just _) = Disp.text "True" - - toAllowNewer True = Just AllowNewerAll - toAllowNewer False = Just AllowNewerNone - - pkgs = (Just . AllowNewerSome) `fmap` parseOptCommaList Text.parse - parseAllowNewer = (toAllowNewer `fmap` Text.parse) Parse.<++ pkgs in + ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse + parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in + simpleField "allow-older" + (showRelaxDeps . fmap unAllowOlder) parseAllowOlder + configAllowOlder (\v flags -> flags { configAllowOlder = v }) + ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse + parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in simpleField "allow-newer" - showAllowNewer parseAllowNewer + (showRelaxDeps . fmap unAllowNewer) parseAllowNewer configAllowNewer (\v flags -> flags { configAllowNewer = v }) -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr @@ -797,7 +825,7 @@ ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) - ["verbose", "check", "documentation"] [] + ["verbose", "check", "documentation", "publish"] [] ++ toSavedConfig liftReportFlag (commandOptions reportCommand ParseArgs) @@ -831,6 +859,15 @@ , name `notElem` exclusions ] optional = Parse.option mempty . fmap toFlag + + showRelaxDeps Nothing = mempty + showRelaxDeps (Just RelaxDepsNone) = Disp.text "False" + showRelaxDeps (Just _) = Disp.text "True" + + toRelaxDeps True = RelaxDepsAll + toRelaxDeps False = RelaxDepsNone + + -- TODO: next step, make the deprecated fields elicit a warning. -- deprecatedFieldDescriptions :: [FieldDescr SavedConfig] @@ -1004,8 +1041,8 @@ showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $ - case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos - . savedGlobalFlags $ vals of + case fmap (uncurry ppRemoteRepoSection) + (zip (getRemoteRepos comment) (getRemoteRepos vals)) of [] -> Disp.text "" (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs $+$ Disp.text "" @@ -1025,6 +1062,7 @@ $+$ configFlagsSection "program-default-options" withProgramOptionsFields configProgramArgs where + getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags mcomment = Just comment installDirsSection name field = ppSection "install-dirs" name installDirsFields @@ -1042,11 +1080,9 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions -ppRemoteRepoSection :: RemoteRepo -> Doc -ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals) - remoteRepoFields def vals - where - def = Just (emptyRemoteRepo "ignored") { remoteRepoSecure = Just False } +ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc +ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals) + remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = @@ -1094,14 +1130,14 @@ withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields = map viewAsFieldDescr $ - programConfigurationPaths' (++ "-location") defaultProgramConfiguration + programDbPaths' (++ "-location") defaultProgramDb ParseArgs id (++) -- | Fields for the 'program-default-options' section. withProgramOptionsFields :: [FieldDescr [(String, [String])]] withProgramOptionsFields = map viewAsFieldDescr $ - programConfigurationOptions defaultProgramConfiguration ParseArgs id (++) + programDbOptions defaultProgramDb ParseArgs id (++) -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -15,70 +15,82 @@ configure, configureSetupScript, chooseCabalVersion, - checkConfigExFlags + checkConfigExFlags, + -- * Saved configure flags + readConfigFlagsFrom, readConfigFlags, + cabalConfigFlagsFile, + writeConfigFlagsTo, writeConfigFlags, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types - ( ConstraintSource(..) - , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName ) -import Distribution.Client.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Client.Setup - ( ConfigExFlags(..), configureCommand, filterConfigureFlags - , RepoContext(..) ) + ( ConfigExFlags(..), RepoContext(..) + , configureCommand, configureExCommand, filterConfigureFlags ) import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets ( userToPackageConstraint, userConstraintPackageName ) -import qualified Distribution.Client.ComponentDeps as CD import Distribution.Package (PackageId) import Distribution.Client.JobControl (Lock) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageIndex + ( PackageIndex, elemByPackageName ) +import Distribution.Solver.Types.PkgConfigDb + (PkgConfigDb, readPkgConfigDb) +import Distribution.Solver.Types.SourcePackage + import Distribution.Simple.Compiler ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration ) +import Distribution.Simple.Program (ProgramDb) +import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup - ( ConfigFlags(..), AllowNewer(..) + ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..) , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, lookupPackageName ) import Distribution.Simple.Utils ( defaultPackageDesc ) -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package - ( Package(..), UnitId, packageName - , Dependency(..), thisPackageVersion - ) + ( Package(..), packageName ) +import Distribution.Types.Dependency + ( Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +#else import Distribution.PackageDescription.Parse - ( readPackageDescription ) + ( readGenericPackageDescription ) +#endif import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) + ( finalizePD ) import Distribution.Version - ( anyVersion, thisVersion ) + ( Version, mkVersion, anyVersion, thisVersion + , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die ) + ( warn, notice, debug, die' ) import Distribution.Simple.Setup - ( isAllowNewer ) + ( isRelaxDeps ) import Distribution.System ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity ( Verbosity ) -import Distribution.Version - ( Version(..), VersionRange, orLaterVersion ) -import Control.Monad (unless) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) -#endif -import Data.Maybe (isJust, fromMaybe) +import System.FilePath ( () ) -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. @@ -88,11 +100,13 @@ where -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed -- for '--allow-newer' to work. - allowNewer = isAllowNewer - (fromMaybe AllowNewerNone $ configAllowNewer configFlags) + allowNewer = isRelaxDeps + (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags) + allowOlder = isRelaxDeps + (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags) - defaultVersionRange = if allowNewer - then orLaterVersion (Version [1,19,2] []) + defaultVersionRange = if allowOlder || allowNewer + then orLaterVersion (mkVersion [1,19,2]) else anyVersion -- | Configure the package found in the local directory @@ -101,17 +115,17 @@ -> RepoContext -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> ConfigFlags -> ConfigExFlags -> [String] -> IO () -configure verbosity packageDBs repoCtxt comp platform conf +configure verbosity packageDBs repoCtxt comp platform progdb configFlags configExFlags extraArgs = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity conf + pkgConfigDb <- readPkgConfigDb verbosity progdb checkConfigExFlags verbosity installedPkgIndex (packageIndex sourcePkgDb) configExFlags @@ -131,17 +145,18 @@ setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) Nothing configureCommand (const configFlags) extraArgs - Right installPlan -> case InstallPlan.ready installPlan of + Right installPlan0 -> + let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 + in case fst (InstallPlan.ready installPlan) of [pkg@(ReadyPackage - (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) - _ _ _) - _)] -> do + (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) + _ _ _))] -> do configurePackage verbosity platform (compilerInfo comp) (setupScriptOptions installedPkgIndex (Just pkg)) configFlags pkg extraArgs - _ -> die $ "internal error: configure install plan should have exactly " + _ -> die' verbosity $ "internal error: configure install plan should have exactly " ++ "one local ready package." where @@ -153,7 +168,7 @@ packageDBs comp platform - conf + progdb (fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (configDistPref configFlags)) @@ -168,7 +183,7 @@ configureSetupScript :: PackageDBStack -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> FilePath -> VersionRange -> Maybe Lock @@ -179,7 +194,7 @@ configureSetupScript packageDBs comp platform - conf + progdb distPref cabalVersion lock @@ -193,10 +208,11 @@ , usePlatform = Just platform , usePackageDB = packageDBs' , usePackageIndex = index' - , useProgramConfig = conf + , useProgramDb = progdb , useDistPref = distPref , useLoggingHandle = Nothing , useWorkingDir = Nothing + , useExtraPathEnv = [] , setupCacheLock = lock , useWin32CleanHack = False , forceExternalSetupMethod = forceExternal @@ -209,6 +225,7 @@ , useDependencies = fromMaybe [] explicitSetupDeps , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps + , isInteractive = False } where -- When we are compiling a legacy setup script without an explicit @@ -228,8 +245,8 @@ maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo maybeSetupBuildInfo = do - ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) _ - <- mpkg + ReadyPackage cpkg <- mpkg + let gpkg = packageDescription (confPkgSource cpkg) PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg) -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If @@ -238,16 +255,14 @@ defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends maybeSetupBuildInfo - explicitSetupDeps :: Maybe [(UnitId, PackageId)] + explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] explicitSetupDeps = do -- Check if there is an explicit setup stanza. _buildInfo <- maybeSetupBuildInfo -- Return the setup dependencies computed by the solver - ReadyPackage _ deps <- mpkg - return [ ( Installed.installedUnitId deppkg - , Installed.sourcePackageId deppkg - ) - | deppkg <- CD.setupDeps deps + ReadyPackage cpkg <- mpkg + return [ ( cid, srcid ) + | ConfiguredId srcid (Just PkgDesc.CLibName) cid <- CD.setupDeps (confPkgDeps cpkg) ] -- | Warn if any constraints or preferences name packages that are not in the @@ -284,17 +299,20 @@ -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb - -> IO (Progress String String InstallPlan) + -> IO (Progress String String SolverInstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do - pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + pkg <- readGenericPackageDescription verbosity =<< + case flagToMaybe (configCabalFilePath configFlags) of + Nothing -> defaultPackageDesc verbosity + Just fp -> return fp solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp) let -- We create a local package and ask to resolve a dependency on it localPkg = SourcePackage { packageInfoId = packageId pkg, - Source.packageDescription = pkg, + packageDescription = pkg, packageSource = LocalUnpackedPackage ".", packageDescrOverride = Nothing } @@ -304,8 +322,10 @@ fromFlagOrDefault False $ configBenchmarks configFlags resolverParams = - removeUpperBounds - (fromMaybe AllowNewerNone $ configAllowNewer configFlags) + removeLowerBounds + (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags) + . removeUpperBounds + (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags) . addPreferences -- preferences from the config file or command line @@ -321,22 +341,34 @@ . addConstraints -- package flags from the config file or command line - [ let pc = PackageConstraintFlags (packageName pkg) - (configConfigurationsFlags configFlags) + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- the config file or command line - [ let pc = PackageConstraintStanzas (packageName pkg) $ + [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . + PackagePropertyStanzas $ [ TestStanzas | testsEnabled ] ++ [ BenchStanzas | benchmarksEnabled ] in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] + -- Don't solve for executables, since we use an empty source + -- package database and executables never show up in the + -- installed package index + . setSolveExecutables (SolveExecutables False) + + . setSolverVerbosity verbosity + $ standardInstallPolicy installedPkgIndex + -- NB: We pass in an *empty* source package database, + -- because cabal configure assumes that all dependencies + -- have already been installed (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] @@ -359,34 +391,78 @@ -> [String] -> IO () configurePackage verbosity platform comp scriptOptions configFlags - (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) - flags stanzas _) - deps) + (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps)) extraArgs = setupWrapper verbosity scriptOptions (Just pkg) configureCommand configureFlags extraArgs where + gpkg = packageDescription spkg configureFlags = filterConfigureFlags configFlags { + configIPID = if isJust (flagToMaybe (configIPID configFlags)) + -- Make sure cabal configure --ipid works. + then configIPID configFlags + else toFlag (display ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise -- deps. In the end only one set gets passed to Setup.hs configure, -- depending on the Cabal version we are talking to. - configConstraints = [ thisPackageVersion (packageId deppkg) - | deppkg <- CD.nonSetupDeps deps ], - configDependencies = [ (packageName (Installed.sourcePackageId deppkg), - Installed.installedUnitId deppkg) - | deppkg <- CD.nonSetupDeps deps ], + configConstraints = [ thisPackageVersion srcid + | ConfiguredId srcid (Just PkgDesc.CLibName) _uid <- CD.nonSetupDeps deps ], + configDependencies = [ (packageName srcid, uid) + | ConfiguredId srcid (Just PkgDesc.CLibName) uid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configVerbosity = toFlag verbosity, - configBenchmarks = toFlag (BenchStanzas `elem` stanzas), + -- NB: if the user explicitly specified + -- --enable-tests/--enable-benchmarks, always respect it. + -- (But if they didn't, let solver decide.) + configBenchmarks = toFlag (BenchStanzas `elem` stanzas) + `mappend` configBenchmarks configFlags, configTests = toFlag (TestStanzas `elem` stanzas) + `mappend` configTests configFlags } - pkg = case finalizePackageDescription flags + pkg = case finalizePD flags (enableStanzas stanzas) (const True) - platform comp [] (enableStanzas stanzas gpkg) of - Left _ -> error "finalizePackageDescription ReadyPackage failed" + platform comp [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" Right (desc, _) -> desc + +-- ----------------------------------------------------------------------------- +-- * Saved configure environments and flags +-- ----------------------------------------------------------------------------- + +-- | Read saved configure flags and restore the saved environment from the +-- specified files. +readConfigFlagsFrom :: FilePath -- ^ path to saved flags file + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlagsFrom flags = do + readCommandFlags flags configureExCommand + +-- | The path (relative to @--build-dir@) where the arguments to @configure@ +-- should be saved. +cabalConfigFlagsFile :: FilePath -> FilePath +cabalConfigFlagsFile dist = dist "cabal-config-flags" + +-- | Read saved configure flags and restore the saved environment from the +-- usual location. +readConfigFlags :: FilePath -- ^ @--build-dir@ + -> IO (ConfigFlags, ConfigExFlags) +readConfigFlags dist = + readConfigFlagsFrom (cabalConfigFlagsFile dist) + +-- | Save the configure flags and environment to the specified files. +writeConfigFlagsTo :: FilePath -- ^ path to saved flags file + -> Verbosity -> (ConfigFlags, ConfigExFlags) + -> IO () +writeConfigFlagsTo file verb flags = do + writeCommandFlags verb file configureExCommand flags + +-- | Save the build flags to the usual location. +writeConfigFlags :: Verbosity + -> FilePath -- ^ @--build-dir@ + -> (ConfigFlags, ConfigExFlags) -> IO () +writeConfigFlags verb dist = + writeConfigFlagsTo (cabalConfigFlagsFile dist) verb diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -23,13 +23,14 @@ resolveWithoutDependencies, -- * Constructing resolver policies - DepResolverParams(..), + PackageProperty(..), PackageConstraint(..), + scopeToplevel, PackagesPreferenceDefault(..), PackagePreference(..), - InstalledPreference(..), -- ** Standard policy + basicInstallPolicy, standardInstallPolicy, PackageSpecifier(..), @@ -37,8 +38,6 @@ applySandboxInstallPolicy, -- ** Extra policy options - dontUpgradeNonUpgradeablePackages, - hideBrokenInstalledPackages, upgradeDependencies, reinstallTargets, @@ -47,60 +46,52 @@ addPreferences, setPreferenceDefault, setReorderGoals, + setCountConflicts, setIndependentGoals, setAvoidReinstalls, setShadowPkgs, setStrongFlags, + setAllowBootLibInstalls, setMaxBackjumps, - addSourcePackages, - hideInstalledPackagesSpecificByUnitId, - hideInstalledPackagesSpecificBySourcePackageId, - hideInstalledPackagesAllVersions, + setEnableBackjumping, + setSolveExecutables, + setGoalOrder, + setSolverVerbosity, + removeLowerBounds, removeUpperBounds, addDefaultSetupDependencies, + addSetupCabalMinVersionConstraint, ) where -import Distribution.Client.Dependency.TopDown - ( topDownResolver ) -import Distribution.Client.Dependency.Modular +import Distribution.Solver.Modular ( modularResolver, SolverConfig(..) ) -import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.PkgConfigDb (PkgConfigDb) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types - ( SourcePackageDb(SourcePackageDb), SourcePackage(..) - , ConfiguredPackage(..), ConfiguredId(..) - , OptionalStanza(..), enableStanzas ) + ( SourcePackageDb(SourcePackageDb) + , UnresolvedPkgLoc, UnresolvedSourcePackage ) import Distribution.Client.Dependency.Types - ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..) - , PackageConstraint(..), showPackageConstraint - , LabeledPackageConstraint(..), unlabelPackageConstraint - , ConstraintSource(..), showConstraintSource - , PackagePreferences(..), InstalledPreference(..) - , PackagesPreferenceDefault(..) - , Progress(..), foldProgress ) + ( PreSolver(..), Solver(..) + , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) ) import Distribution.Client.Targets -import Distribution.Client.ComponentDeps (ComponentDeps) -import qualified Distribution.Client.ComponentDeps as CD -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package - ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId - , Package(..), packageName, packageVersion - , UnitId, Dependency(Dependency)) + ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) + ( finalizePD ) import Distribution.Client.PackageUtils ( externalBuildDepends ) import Distribution.Version - ( VersionRange, Version(..), anyVersion, orLaterVersion, thisVersion - , withinRange, simplifyVersionRange ) + ( Version, mkVersion + , VersionRange, anyVersion, thisVersion, orLaterVersion, withinRange + , simplifyVersionRange, removeLowerBound, removeUpperBound ) import Distribution.Compiler ( CompilerInfo(..) ) import Distribution.System @@ -108,20 +99,41 @@ import Distribution.Client.Utils ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils - ( comparing, warn, info ) + ( comparing ) import Distribution.Simple.Configure ( relaxPackageDeps ) import Distribution.Simple.Setup - ( AllowNewer(..) ) + ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Text ( display ) import Distribution.Verbosity - ( Verbosity ) + ( normal, Verbosity ) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable + import Data.List ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) @@ -138,37 +150,54 @@ -- implemented in terms of adjustments to the parameters. -- data DepResolverParams = DepResolverParams { - depResolverTargets :: [PackageName], + depResolverTargets :: Set PackageName, depResolverConstraints :: [LabeledPackageConstraint], depResolverPreferences :: [PackagePreference], depResolverPreferenceDefault :: PackagesPreferenceDefault, depResolverInstalledPkgIndex :: InstalledPackageIndex, - depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage, - depResolverReorderGoals :: Bool, - depResolverIndependentGoals :: Bool, - depResolverAvoidReinstalls :: Bool, - depResolverShadowPkgs :: Bool, - depResolverStrongFlags :: Bool, - depResolverMaxBackjumps :: Maybe Int + depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, + depResolverReorderGoals :: ReorderGoals, + depResolverCountConflicts :: CountConflicts, + depResolverIndependentGoals :: IndependentGoals, + depResolverAvoidReinstalls :: AvoidReinstalls, + depResolverShadowPkgs :: ShadowPkgs, + depResolverStrongFlags :: StrongFlags, + + -- | Whether to allow base and its dependencies to be installed. + depResolverAllowBootLibInstalls :: AllowBootLibInstalls, + + depResolverMaxBackjumps :: Maybe Int, + depResolverEnableBackjumping :: EnableBackjumping, + -- | Whether or not to solve for dependencies on executables. + -- This should be true, except in the legacy code path where + -- we can't tell if an executable has been installed or not, + -- so we shouldn't solve for them. See #3875. + depResolverSolveExecutables :: SolveExecutables, + + -- | Function to override the solver's goal-ordering heuristics. + depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + depResolverVerbosity :: Verbosity } showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = - "targets: " ++ intercalate ", " (map display (depResolverTargets p)) + "targets: " ++ intercalate ", " (map display $ Set.toList (depResolverTargets p)) ++ "\nconstraints: " ++ concatMap (("\n " ++) . showLabeledConstraint) (depResolverConstraints p) ++ "\npreferences: " ++ concatMap (("\n " ++) . showPackagePreference) (depResolverPreferences p) - ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " ++ show (depResolverReorderGoals p) - ++ "\nindependent goals: " ++ show (depResolverIndependentGoals p) - ++ "\navoid reinstalls: " ++ show (depResolverAvoidReinstalls p) - ++ "\nshadow packages: " ++ show (depResolverShadowPkgs p) - ++ "\nstrong flags: " ++ show (depResolverStrongFlags p) + ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) + ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) + ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) + ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) + ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) + ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) + ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) + ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) ++ "\nmax backjumps: " ++ maybe "infinite" show - (depResolverMaxBackjumps p) + (depResolverMaxBackjumps p) where showLabeledConstraint :: LabeledPackageConstraint -> String showLabeledConstraint (LabeledPackageConstraint pc src) = @@ -205,29 +234,35 @@ display pn ++ " " ++ show st basicDepResolverParams :: InstalledPackageIndex - -> PackageIndex.PackageIndex SourcePackage + -> PackageIndex.PackageIndex UnresolvedSourcePackage -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex = DepResolverParams { - depResolverTargets = [], + depResolverTargets = Set.empty, depResolverConstraints = [], depResolverPreferences = [], depResolverPreferenceDefault = PreferLatestForSelected, depResolverInstalledPkgIndex = installedPkgIndex, depResolverSourcePkgIndex = sourcePkgIndex, - depResolverReorderGoals = False, - depResolverIndependentGoals = False, - depResolverAvoidReinstalls = False, - depResolverShadowPkgs = False, - depResolverStrongFlags = False, - depResolverMaxBackjumps = Nothing + depResolverReorderGoals = ReorderGoals False, + depResolverCountConflicts = CountConflicts True, + depResolverIndependentGoals = IndependentGoals False, + depResolverAvoidReinstalls = AvoidReinstalls False, + depResolverShadowPkgs = ShadowPkgs False, + depResolverStrongFlags = StrongFlags False, + depResolverAllowBootLibInstalls = AllowBootLibInstalls False, + depResolverMaxBackjumps = Nothing, + depResolverEnableBackjumping = EnableBackjumping True, + depResolverSolveExecutables = SolveExecutables True, + depResolverGoalOrder = Nothing, + depResolverVerbosity = normal } addTargets :: [PackageName] -> DepResolverParams -> DepResolverParams addTargets extraTargets params = params { - depResolverTargets = extraTargets ++ depResolverTargets params + depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params } addConstraints :: [LabeledPackageConstraint] @@ -253,42 +288,80 @@ depResolverPreferenceDefault = preferenceDefault } -setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams -setReorderGoals b params = +setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams +setReorderGoals reorder params = params { - depResolverReorderGoals = b + depResolverReorderGoals = reorder } -setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams -setIndependentGoals b params = +setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams +setCountConflicts count params = params { - depResolverIndependentGoals = b + depResolverCountConflicts = count } -setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams -setAvoidReinstalls b params = +setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams +setIndependentGoals indep params = params { - depResolverAvoidReinstalls = b + depResolverIndependentGoals = indep } -setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams -setShadowPkgs b params = +setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams +setAvoidReinstalls avoid params = params { - depResolverShadowPkgs = b + depResolverAvoidReinstalls = avoid } -setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams -setStrongFlags b params = +setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams +setShadowPkgs shadow params = params { - depResolverStrongFlags = b + depResolverShadowPkgs = shadow } +setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams +setStrongFlags sf params = + params { + depResolverStrongFlags = sf + } + +setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams +setAllowBootLibInstalls i params = + params { + depResolverAllowBootLibInstalls = i + } + setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params = params { depResolverMaxBackjumps = n } +setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams +setEnableBackjumping b params = + params { + depResolverEnableBackjumping = b + } + +setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams +setSolveExecutables b params = + params { + depResolverSolveExecutables = b + } + +setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + -> DepResolverParams + -> DepResolverParams +setGoalOrder order params = + params { + depResolverGoalOrder = order + } + +setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams +setSolverVerbosity verbosity params = + params { + depResolverVerbosity = verbosity + } + -- | Some packages are specific to a given compiler version and should never be -- upgraded. dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams @@ -297,20 +370,24 @@ where extraConstraints = [ LabeledPackageConstraint - (PackageConstraintInstalled pkgname) + (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) ConstraintSourceNonUpgradeablePackage - | notElem (PackageName "base") (depResolverTargets params) - , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp" - , "integer-simple" ] + | Set.notMember (mkPackageName "base") (depResolverTargets params) + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Solver.Modular.Solver" as well + , pkgname <- [ mkPackageName "base" + , mkPackageName "ghc-prim" + , mkPackageName "integer-gmp" + , mkPackageName "integer-simple" + , mkPackageName "template-haskell" + ] , isInstalled pkgname ] - -- TODO: the top down resolver chokes on the base constraints - -- below when there are no targets and thus no dep on base. - -- Need to refactor constraints separate from needing packages. + isInstalled = not . null . InstalledPackageIndex.lookupPackageName (depResolverInstalledPkgIndex params) -addSourcePackages :: [SourcePackage] +addSourcePackages :: [UnresolvedSourcePackage] -> DepResolverParams -> DepResolverParams addSourcePackages pkgs params = params { @@ -319,17 +396,6 @@ (depResolverSourcePkgIndex params) pkgs } -hideInstalledPackagesSpecificByUnitId :: [UnitId] - -> DepResolverParams - -> DepResolverParams -hideInstalledPackagesSpecificByUnitId pkgids params = - --TODO: this should work using exclude constraints instead - params { - depResolverInstalledPkgIndex = - foldl' (flip InstalledPackageIndex.deleteUnitId) - (depResolverInstalledPkgIndex params) pkgids - } - hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] -> DepResolverParams -> DepResolverParams @@ -352,17 +418,6 @@ } -hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams -hideBrokenInstalledPackages params = - hideInstalledPackagesSpecificByUnitId pkgids params - where - pkgids = map Installed.installedUnitId - . InstalledPackageIndex.reverseDependencyClosure - (depResolverInstalledPkgIndex params) - . map (Installed.installedUnitId . fst) - . InstalledPackageIndex.brokenPackages - $ depResolverInstalledPkgIndex params - -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none). -- @@ -371,27 +426,43 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams -removeUpperBounds AllowNewerNone params = params -removeUpperBounds allowNewer params = +removeUpperBounds (AllowNewer RelaxDepsNone) params = params +removeUpperBounds (AllowNewer allowNewer) params = params { depResolverSourcePkgIndex = sourcePkgIndex' } where sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params - relaxDeps :: SourcePackage -> SourcePackage + relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage relaxDeps srcPkg = srcPkg { - packageDescription = relaxPackageDeps allowNewer + packageDescription = relaxPackageDeps removeUpperBound allowNewer (packageDescription srcPkg) } +-- | Dual of 'removeUpperBounds' +removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams +removeLowerBounds (AllowOlder RelaxDepsNone) params = params +removeLowerBounds (AllowOlder allowNewer) params = + params { + depResolverSourcePkgIndex = sourcePkgIndex' + } + where + sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params + + relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + relaxDeps srcPkg = srcPkg { + packageDescription = relaxPackageDeps removeLowerBound allowNewer + (packageDescription srcPkg) + } + -- | Supply defaults for packages without explicit Setup dependencies -- -- Note: It's important to apply 'addDefaultSetupDepends' after -- 'addSourcePackages'. Otherwise, the packages inserted by -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- -addDefaultSetupDependencies :: (SourcePackage -> Maybe [Dependency]) +addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency]) -> DepResolverParams -> DepResolverParams addDefaultSetupDependencies defaultSetupDeps params = params { @@ -399,7 +470,7 @@ fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params) } where - applyDefaultSetupDeps :: SourcePackage -> SourcePackage + applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage applyDefaultSetupDeps srcpkg = srcpkg { packageDescription = gpkgdesc { @@ -420,21 +491,38 @@ gpkgdesc = packageDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc +-- | If a package has a custom setup then we need to add a setup-depends +-- on Cabal. +-- +addSetupCabalMinVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMinVersionConstraint minVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) + ConstraintSetupCabalMinVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest reinstallTargets :: DepResolverParams -> DepResolverParams reinstallTargets params = - hideInstalledPackagesAllVersions (depResolverTargets params) params + hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params -standardInstallPolicy :: InstalledPackageIndex - -> SourcePackageDb - -> [PackageSpecifier SourcePackage] - -> DepResolverParams -standardInstallPolicy +-- | A basic solver policy on which all others are built. +-- +basicInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +basicInstallPolicy installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) pkgSpecifiers @@ -451,20 +539,35 @@ . hideInstalledPackagesSpecificBySourcePackageId [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - . addDefaultSetupDependencies mkDefaultSetupDeps - . addSourcePackages [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] $ basicDepResolverParams installedPkgIndex sourcePkgIndex + +-- | The policy used by all the standard commands, install, fetch, freeze etc +-- (but not the new-build and related commands). +-- +-- It extends the 'basicInstallPolicy' with a policy on setup deps. +-- +standardInstallPolicy :: InstalledPackageIndex + -> SourcePackageDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> DepResolverParams +standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + = addDefaultSetupDependencies mkDefaultSetupDeps + + $ basicInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers + where -- Force Cabal >= 1.24 dep when the package is affected by #3199. - mkDefaultSetupDeps :: SourcePackage -> Maybe [Dependency] + mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency] mkDefaultSetupDeps srcpkg | affected = - Just [Dependency (PackageName "Cabal") - (orLaterVersion $ Version [1,24] [])] + Just [Dependency (mkPackageName "Cabal") + (orLaterVersion $ mkVersion [1,24])] | otherwise = Nothing where gpkgdesc = packageDescription srcpkg @@ -503,8 +606,9 @@ (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] . addConstraints - [ let pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep | pkg <- modifiedDeps ] @@ -531,19 +635,12 @@ -- ------------------------------------------------------------ chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver -chooseSolver verbosity preSolver _cinfo = +chooseSolver _verbosity preSolver _cinfo = case preSolver of - AlwaysTopDown -> do - warn verbosity "Topdown solver is deprecated" - return TopDown AlwaysModular -> do return Modular - Choose -> do - info verbosity "Choosing modular solver." - return Modular -runSolver :: Solver -> SolverConfig -> DependencyResolver -runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options +runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc runSolver Modular = modularResolver -- | Run the dependency solver. @@ -557,11 +654,11 @@ -> PkgConfigDb -> Solver -> DepResolverParams - -> Progress String String InstallPlan + -> Progress String String SolverInstallPlan --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _pkgConfigDB _solver params - | null (depResolverTargets params) + | Set.null (depResolverTargets params) = return (validateSolverResult platform comp indGoals []) where indGoals = depResolverIndependentGoals params @@ -570,8 +667,10 @@ Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls - shadowing strFlags maxBkjumps) + $ runSolver solver (SolverConfig reordGoals cntConflicts + indGoals noReinstalls + shadowing strFlags allowBootLibs maxBkjumps enableBj + solveExes order verbosity) platform comp installedPkgIndex sourcePkgIndex pkgConfigDB preferences constraints targets where @@ -581,23 +680,23 @@ prefs defpref installedPkgIndex sourcePkgIndex - reorderGoals + reordGoals + cntConflicts indGoals noReinstalls shadowing strFlags - maxBkjumps) = dontUpgradeNonUpgradeablePackages - -- TODO: - -- The modular solver can properly deal with broken - -- packages and won't select them. So the - -- 'hideBrokenInstalledPackages' function should be moved - -- into a module that is specific to the top-down solver. - . (if solver /= Modular then hideBrokenInstalledPackages - else id) - $ params + allowBootLibs + maxBkjumps + enableBj + solveExes + order + verbosity) = + if asBool (depResolverAllowBootLibInstalls params) + then params + else dontUpgradeNonUpgradeablePackages params - preferences = interpretPackagesPreference - (Set.fromList targets) defpref prefs + preferences = interpretPackagesPreference targets defpref prefs -- | Give an interpretation to the global 'PackagesPreference' as @@ -648,24 +747,21 @@ -- validateSolverResult :: Platform -> CompilerInfo - -> Bool - -> [ResolverPackage] - -> InstallPlan + -> IndependentGoals + -> [ResolverPackage UnresolvedPkgLoc] + -> SolverInstallPlan validateSolverResult platform comp indepGoals pkgs = case planPackagesProblems platform comp pkgs of - [] -> case InstallPlan.new indepGoals index of + [] -> case SolverInstallPlan.new indepGoals graph of Right plan -> plan Left problems -> error (formatPlanProblems problems) problems -> error (formatPkgProblems problems) where - index = InstalledPackageIndex.fromList (map toPlanPackage pkgs) - - toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg - toPlanPackage (Configured pkg) = InstallPlan.Configured pkg + graph = Graph.fromDistinctList pkgs formatPkgProblems = formatProblemMessage . map showPlanPackageProblem - formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem + formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem formatProblemMessage problems = unlines $ @@ -673,11 +769,13 @@ : "The proposed (invalid) plan contained the following problems:" : problems ++ "Proposed plan:" - : [InstallPlan.showPlanIndex index] + : [SolverInstallPlan.showPlanIndex pkgs] data PlanPackageProblem = - InvalidConfiguredPackage ConfiguredPackage [PackageProblem] + InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) + [PackageProblem] + | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = @@ -685,15 +783,20 @@ ++ " has an invalid configuration, in particular:\n" ++ unlines [ " " ++ showPackageProblem problem | problem <- packageProblems ] +showPlanPackageProblem (DuplicatePackageSolverId pid dups) = + "Package " ++ display (packageId pid) ++ " has " + ++ show (length dups) ++ " duplicate instances." planPackagesProblems :: Platform -> CompilerInfo - -> [ResolverPackage] + -> [ResolverPackage UnresolvedPkgLoc] -> [PlanPackageProblem] planPackagesProblems platform cinfo pkgs = [ InvalidConfiguredPackage pkg packageProblems | Configured pkg <- pkgs , let packageProblems = configuredPackageProblems platform cinfo pkg , not (null packageProblems) ] + ++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups + | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] data PackageProblem = DuplicateFlag PD.FlagName | MissingFlag PD.FlagName @@ -704,14 +807,14 @@ | InvalidDep Dependency PackageId showPackageProblem :: PackageProblem -> String -showPackageProblem (DuplicateFlag (PD.FlagName flag)) = - "duplicate flag in the flag assignment: " ++ flag +showPackageProblem (DuplicateFlag flag) = + "duplicate flag in the flag assignment: " ++ PD.unFlagName flag -showPackageProblem (MissingFlag (PD.FlagName flag)) = - "missing an assignment for the flag: " ++ flag +showPackageProblem (MissingFlag flag) = + "missing an assignment for the flag: " ++ PD.unFlagName flag -showPackageProblem (ExtraFlag (PD.FlagName flag)) = - "extra flag given that is not used by the package: " ++ flag +showPackageProblem (ExtraFlag flag) = + "extra flag given that is not used by the package: " ++ PD.unFlagName flag showPackageProblem (DuplicateDeps pkgids) = "duplicate packages specified as selected dependencies: " @@ -736,9 +839,9 @@ -- dependencies are satisfied by the specified packages. -- configuredPackageProblems :: Platform -> CompilerInfo - -> ConfiguredPackage -> [PackageProblem] + -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo - (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') = + (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] @@ -749,9 +852,10 @@ ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps , not (packageSatisfiesDependency pkgid dep) ] + -- TODO: sanity tests on executable deps where specifiedDeps :: ComponentDeps [PackageId] - specifiedDeps = fmap (map confSrcId) specifiedDeps' + specifiedDeps = fmap (map solverSrcId) specifiedDeps' mergedFlags = mergeBy compare (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg))) @@ -785,12 +889,13 @@ -- of the `nubOn` in `mergeDeps`. requiredDeps :: [Dependency] requiredDeps = - --TODO: use something lower level than finalizePackageDescription - case finalizePackageDescription specifiedFlags + --TODO: use something lower level than finalizePD + case finalizePD specifiedFlags + (enableStanzas stanzas) (const True) platform cinfo [] - (enableStanzas stanzas $ packageDescription pkg) of + (packageDescription pkg) of Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) @@ -817,14 +922,15 @@ -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams - -> Either [ResolveNoDepsError] [SourcePackage] + -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps) = - collectEithers (map selectPackage targets) + _reorderGoals _countConflicts _indGoals _avoidReinstalls + _shadowing _strFlags _maxBjumps _enableBj + _solveExes _allowBootLibInstalls _order _verbosity) = + collectEithers $ map selectPackage (Set.toList targets) where - selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage + selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage selectPackage pkgname | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions | otherwise = Right $! maximumBy bestByPrefs choices @@ -856,12 +962,12 @@ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap packageVersionConstraintMap = let pcs = map unlabelPackageConstraint constraints - in Map.fromList [ (name, range) - | PackageConstraintVersion name range <- pcs ] + in Map.fromList [ (scopeToPackageName scope, range) + | PackageConstraint + scope (PackagePropertyVersion range) <- pcs ] packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference - (Set.fromList targets) defpref prefs + packagePreferences = interpretPackagesPreference targets defpref prefs collectEithers :: [Either a b] -> Either [a] [b] diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Distribution.Client.Dependency.Modular - ( modularResolver, SolverConfig(..)) where - --- Here, we try to map between the external cabal-install solver --- interface and the internal interface that the solver actually --- expects. There are a number of type conversions to perform: we --- have to convert the package indices to the uniform index used --- by the solver; we also have to convert the initial constraints; --- and finally, we have to convert back the resulting install --- plan. - -import Data.Map as M - ( fromListWith ) -import Distribution.Client.Dependency.Modular.Assignment - ( Assignment, toCPs ) -import Distribution.Client.Dependency.Modular.Dependency - ( RevDepMap ) -import Distribution.Client.Dependency.Modular.ConfiguredConversion - ( convCP ) -import Distribution.Client.Dependency.Modular.IndexConversion - ( convPIs ) -import Distribution.Client.Dependency.Modular.Log - ( logToProgress ) -import Distribution.Client.Dependency.Modular.Package - ( PN ) -import Distribution.Client.Dependency.Modular.Solver - ( SolverConfig(..), solve ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, ResolverPackage - , PackageConstraint(..), unlabelPackageConstraint ) -import Distribution.System - ( Platform(..) ) - --- | Ties the two worlds together: classic cabal-install vs. the modular --- solver. Performs the necessary translations before and after. -modularResolver :: SolverConfig -> DependencyResolver -modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - fmap (uncurry postprocess) $ -- convert install plan - logToProgress (maxBackjumps sc) $ -- convert log format into progress format - solve sc cinfo idx pkgConfigDB pprefs gcs pns - where - -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx - -- Constraints have to be converted into a finite map indexed by PN. - gcs = M.fromListWith (++) (map pair pcs) - where - pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) - - -- Results have to be converted into an install plan. - postprocess :: Assignment -> RevDepMap -> [ResolverPackage] - postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm) - - -- Helper function to extract the PN from a constraint. - pcName :: PackageConstraint -> PN - pcName (PackageConstraintVersion pn _) = pn - pcName (PackageConstraintInstalled pn ) = pn - pcName (PackageConstraintSource pn ) = pn - pcName (PackageConstraintFlags pn _) = pn - pcName (PackageConstraintStanzas pn _) = pn diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Assignment.hs +++ /dev/null @@ -1,150 +0,0 @@ -module Distribution.Client.Dependency.Modular.Assignment - ( Assignment(..) - , FAssignment - , SAssignment - , PreAssignment(..) - , extend - , toCPs - ) where - -import Control.Applicative -import Control.Monad -import Data.Array as A -import Data.List as L -import Data.Map as M -import Data.Maybe -import Prelude hiding (pi) - -import Language.Haskell.Extension (Extension, Language) - -import Distribution.PackageDescription (FlagAssignment) -- from Cabal -import Distribution.Client.Types (OptionalStanza) -import Distribution.Client.Utils.LabeledGraph -import Distribution.Client.ComponentDeps (ComponentDeps, Component) -import qualified Distribution.Client.ComponentDeps as CD - -import Distribution.Client.Dependency.Modular.Configured -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Version - --- | A (partial) package assignment. Qualified package names --- are associated with instances. -type PAssignment = Map QPN I - --- | A (partial) package preassignment. Qualified package names --- are associated with constrained instances. Constrained instances --- record constraints about the instances that can still be chosen, --- and in the extreme case fix a concrete instance. -type PPreAssignment = Map QPN (CI QPN) -type FAssignment = Map QFN Bool -type SAssignment = Map QSN Bool - --- | A (partial) assignment of variables. -data Assignment = A PAssignment FAssignment SAssignment - deriving (Show, Eq) - --- | A preassignment comprises knowledge about variables, but not --- necessarily fixed values. -data PreAssignment = PA PPreAssignment FAssignment SAssignment - --- | Extend a package preassignment. --- --- Takes the variable that causes the new constraints, a current preassignment --- and a set of new dependency constraints. --- --- We're trying to extend the preassignment with each dependency one by one. --- Each dependency is for a particular variable. We check if we already have --- constraints for that variable in the current preassignment. If so, we're --- trying to merge the constraints. --- --- Either returns a witness of the conflict that would arise during the merge, --- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PN -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> Var QPN - -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment -extend extSupported langSupported pkgPresent var = foldM extendSingle - where - - extendSingle :: PPreAssignment -> Dep QPN - -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment - extendSingle a (Ext ext ) = - if extSupported ext then Right a - else Left (varToConflictSet var, [Ext ext]) - extendSingle a (Lang lang) = - if langSupported lang then Right a - else Left (varToConflictSet var, [Lang lang]) - extendSingle a (Pkg pn vr) = - if pkgPresent pn vr then Right a - else Left (varToConflictSet var, [Pkg pn vr]) - extendSingle a (Dep qpn ci) = - let ci' = M.findWithDefault (Constrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge ci' ci of - Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d')) - Right x -> Right x - - -- We're trying to remove trivial elements of the conflict. If we're just - -- making a choice pkg == instance, and pkg => pkg == instance is a part - -- of the conflict, then this info is clear from the context and does not - -- have to be repeated. - simplify v (Fixed _ var') c | v == var && var' == var = [c] - simplify v c (Fixed _ var') | v == var && var' == var = [c] - simplify _ c d = [c, d] - --- | Delivers an ordered list of fully configured packages. --- --- TODO: This function is (sort of) ok. However, there's an open bug --- w.r.t. unqualification. There might be several different instances --- of one package version chosen by the solver, which will lead to --- clashes. -toCPs :: Assignment -> RevDepMap -> [CP QPN] -toCPs (A pa fa sa) rdm = - let - -- get hold of the graph - g :: Graph Component - vm :: Vertex -> ((), QPN, [(Component, QPN)]) - cvm :: QPN -> Maybe Vertex - -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. - (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) - (M.toList rdm)) - tg :: Graph Component - tg = transposeG g - -- Topsort the dependency graph, yielding a list of pkgs in the right order. - -- The graph will still contain all the installed packages, and it might - -- contain duplicates, because several variables might actually resolve to - -- the same package in the presence of qualified package names. - ps :: [PI QPN] - ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ - topSort g - -- Determine the flags per package, by walking over and regrouping the - -- complete flag assignment by package. - fapp :: Map QPN FlagAssignment - fapp = M.fromListWith (++) $ - L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ - M.toList $ - fa - -- Stanzas per package. - sapp :: Map QPN [OptionalStanza] - sapp = M.fromListWith (++) $ - L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ - M.toList $ - sa - -- Dependencies per package. - depp :: QPN -> [(Component, PI QPN)] - depp qpn = let v :: Vertex - v = fromJust (cvm qpn) - dvs :: [(Component, Vertex)] - dvs = tg A.! v - in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs - -- Translated to PackageDeps - depp' :: QPN -> ComponentDeps [PI QPN] - depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp - in - L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault [] qpn fapp) - (M.findWithDefault [] qpn sapp) - (depp' qpn)) - ps diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Builder.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Dependency.Modular.Builder (buildTree) where - --- Building the search tree. --- --- In this phase, we build a search tree that is too large, i.e, it contains --- invalid solutions. We keep track of the open goals at each point. We --- nondeterministically pick an open goal (via a goal choice node), create --- subtrees according to the index and the available solutions, and extend the --- set of open goals by superficially looking at the dependencies recorded in --- the index. --- --- For each goal, we keep track of all the *reasons* why it is being --- introduced. These are for debugging and error messages, mainly. A little bit --- of care has to be taken due to the way we treat flags. If a package has --- flag-guarded dependencies, we cannot introduce them immediately. Instead, we --- store the entire dependency. - -import Data.List as L -import Data.Map as M -import Prelude hiding (sequence, mapM) - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Index -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.PSQ (PSQ) -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import Distribution.Client.Dependency.Modular.Tree - -import Distribution.Client.ComponentDeps (Component) - --- | The state needed during the build phase of the search tree. -data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options -} - --- | Extend the set of open goals with the new goals listed. --- --- We also adjust the map of overall goals, and keep track of the --- reverse dependencies of each of the goals. -extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs - where - go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs - go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs) - | qpn == qpn' = go g o ngs - -- we ignore self-dependencies at this point; TODO: more care may be needed - | qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs - - cons' = P.cons . forgetCompOpenGoal - --- | Given the current scope, qualify all the package names in the given set of --- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo -> - BuildState -> BuildState -scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s - where - -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps - -- Introduce all package flags - qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs - -- Combine new package and flag goals - gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) - -- NOTE: - -- - -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially - -- multiple times, both via the flag declaration and via dependencies. - -- The order is potentially important, because the occurrences via - -- dependencies may record flag-dependency information. After a number - -- of bugs involving computing this information incorrectly, however, - -- we're currently not using carefully computed inter-flag dependencies - -- anymore, but instead use 'simplifyVar' when computing conflict sets - -- to map all flags of one package to a single flag for conflict set - -- purposes, thereby treating them all as interdependent. - -- - -- If we ever move to a more clever algorithm again, then the line above - -- needs to be looked at very carefully, and probably be replaced by - -- more systematically computed flag dependency information. - --- | Datatype that encodes what to build next -data BuildType = - Goals -- ^ build a goal choice node - | OneGoal (OpenGoal ()) -- ^ build a node for this goal - | Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance - deriving Show - -build :: BuildState -> Tree QGoalReason -build = ana go - where - go :: BuildState -> TreeF QGoalReason BuildState - - -- If we have a choice between many goals, we just record the choice in - -- the tree. We select each open goal in turn, and before we descend, remove - -- it from the queue of open goals. - go bs@(BS { rdeps = rds, open = gs, next = Goals }) - | P.null gs = DoneF rds - | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) - (P.splits gs)) - - -- If we have already picked a goal, then the choice depends on the kind - -- of goal. - -- - -- For a package, we look up the instances available in the global info, - -- and then handle each instance in turn. - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) = - error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal" - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) = - error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal" - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = - error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal" - go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) = - -- If the package does not exist in the index, we construct an emty PChoiceF node for it - -- After all, we have no choices here. Alternatively, we could immediately construct - -- a Fail node here, but that would complicate the construction of conflict sets. - -- We will probably want to give this case special treatment when generating error - -- messages though. - case M.lookup pn idx of - Nothing -> PChoiceF qpn gr (P.fromList []) - Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) -> - (POption i Nothing, bs { next = Instance qpn i info gr })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here - - -- For a flag, we create only two subtrees, and we create them in the order - -- that is indicated by the flag default. - -- - -- TODO: Should we include the flag default in the tree? - go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = - FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b - [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }), - (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])) - where - reorder True = id - reorder False = reverse - trivial = L.null t && L.null f - - -- For a stanza, we also create only two subtrees. The order is initially - -- False, True. This can be changed later by constraints (force enabling - -- the stanza by replacing the False branch with failure) or preferences - -- (try enabling the stanza if possible by moving the True branch first). - - go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = - SChoiceF qsn gr trivial (P.fromList - [(False, bs { next = Goals }), - (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })]) - where - trivial = L.null t - - -- For a particular instance, we change the state: we update the scope, - -- and furthermore we update the set of goals. - -- - -- TODO: We could inline this above. - go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) = - go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs) - { next = Goals }) - --- | Interface to the tree builder. Just takes an index and a list of package names, --- and computes the initial state and then the tree from there. -buildTree :: Index -> Bool -> [PN] -> Tree QGoalReason -buildTree idx ind igs = - build BS { - index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns) - , next = Goals - , qualifyOptions = defaultQualifyOptions idx - } - where - topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal - - qpns | ind = makeIndependent igs - | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs diff --git a/Distribution/Client/Dependency/Modular/Configured.hs b/Distribution/Client/Dependency/Modular/Configured.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Configured.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Distribution.Client.Dependency.Modular.Configured - ( CP(..) - ) where - -import Distribution.PackageDescription (FlagAssignment) -- from Cabal -import Distribution.Client.Types (OptionalStanza) -import Distribution.Client.ComponentDeps (ComponentDeps) - -import Distribution.Client.Dependency.Modular.Package - --- | A configured package is a package instance together with --- a flag assignment and complete dependencies. -data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn]) diff --git a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Distribution.Client.Dependency.Modular.ConfiguredConversion - ( convCP - ) where - -import Data.Maybe -import Prelude hiding (pi) - -import Distribution.Package (UnitId) - -import Distribution.Client.Types -import Distribution.Client.Dependency.Types (ResolverPackage(..)) -import qualified Distribution.Client.PackageIndex as CI -import qualified Distribution.Simple.PackageIndex as SI - -import Distribution.Client.Dependency.Modular.Configured -import Distribution.Client.Dependency.Modular.Package - -import Distribution.Client.ComponentDeps (ComponentDeps) - --- | Converts from the solver specific result @CP QPN@ into --- a 'ResolverPackage', which can then be converted into --- the install plan. -convCP :: SI.InstalledPackageIndex -> - CI.PackageIndex SourcePackage -> - CP QPN -> ResolverPackage -convCP iidx sidx (CP qpi fa es ds) = - case convPI qpi of - Left pi -> PreExisting - (fromJust $ SI.lookupUnitId iidx pi) - Right pi -> Configured $ ConfiguredPackage - srcpkg - fa - es - ds' - where - Just srcpkg = CI.lookupPackageId sidx pi - where - ds' :: ComponentDeps [ConfiguredId] - ds' = fmap (map convConfId) ds - -convPI :: PI QPN -> Either UnitId PackageId -convPI (PI _ (I _ (Inst pi))) = Left pi -convPI qpi = Right $ confSrcId $ convConfId qpi - -convConfId :: PI QPN -> ConfiguredId -convConfId (PI (Q _ pn) (I v loc)) = ConfiguredId { - confSrcId = sourceId - , confInstId = installedId - } - where - sourceId = PackageIdentifier pn v - installedId = case loc of - Inst pi -> pi - _otherwise -> fakeUnitId sourceId diff --git a/Distribution/Client/Dependency/Modular/ConflictSet.hs b/Distribution/Client/Dependency/Modular/ConflictSet.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/ConflictSet.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Conflict sets --- --- Intended for double import --- --- > import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet) --- > import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS -module Distribution.Client.Dependency.Modular.ConflictSet ( - ConflictSet -- opaque - , showCS - -- Set-like operations - , toList - , union - , unions - , insert - , empty - , singleton - , member - , filter - , fromList - ) where - -import Prelude hiding (filter) -import Data.List (intercalate) -import Data.Set (Set) -import qualified Data.Set as S - -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Var - --- | The set of variables involved in a solver conflict --- --- Since these variables should be preprocessed in some way, this type is --- kept abstract. -newtype ConflictSet qpn = CS { fromConflictSet :: Set (Var qpn) } - deriving (Eq, Ord, Show) - -showCS :: ConflictSet QPN -> String -showCS = intercalate ", " . map showVar . toList - -{------------------------------------------------------------------------------- - Set-like operations --------------------------------------------------------------------------------} - -toList :: ConflictSet qpn -> [Var qpn] -toList = S.toList . fromConflictSet - -union :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn -union (CS a) (CS b) = CS (a `S.union` b) - -unions :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn -unions = CS . S.unions . map fromConflictSet - -insert :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn -insert var (CS set) = CS (S.insert (simplifyVar var) set) - -empty :: ConflictSet qpn -empty = CS S.empty - -singleton :: Var qpn -> ConflictSet qpn -singleton = CS . S.singleton . simplifyVar - -member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool -member var (CS set) = S.member (simplifyVar var) set - -#if MIN_VERSION_containers(0,5,0) -filter :: (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn -#else -filter :: Ord qpn => (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn -#endif -filter p (CS set) = CS $ S.filter p set - -fromList :: Ord qpn => [Var qpn] -> ConflictSet qpn -fromList = CS . S.fromList . map simplifyVar diff --git a/Distribution/Client/Dependency/Modular/Cycles.hs b/Distribution/Client/Dependency/Modular/Cycles.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Cycles.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Dependency.Modular.Cycles ( - detectCyclesPhase - ) where - -import Prelude hiding (cycle) -import Data.Graph (SCC) -import qualified Data.Graph as Gr -import qualified Data.Map as Map - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS - --- | Find and reject any solutions that are cyclic -detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason -detectCyclesPhase = cata go - where - -- The only node of interest is DoneF - go :: TreeF QGoalReason (Tree QGoalReason) -> Tree QGoalReason - go (PChoiceF qpn gr cs) = PChoice qpn gr cs - go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs - go (SChoiceF qsn gr w cs) = SChoice qsn gr w cs - go (GoalChoiceF cs) = GoalChoice cs - go (FailF cs reason) = Fail cs reason - - -- We check for cycles only if we have actually found a solution - -- This minimizes the number of cycle checks we do as cycles are rare - go (DoneF revDeps) = do - case findCycles revDeps of - Nothing -> Done revDeps - Just relSet -> Fail relSet CyclicDependencies - --- | Given the reverse dependency map from a 'Done' node in the tree, as well --- as the full conflict set containing all decisions that led to that 'Done' --- node, check if the solution is cyclic. If it is, return the conflict set --- containing all decisions that could potentially break the cycle. -findCycles :: RevDepMap -> Maybe (ConflictSet QPN) -findCycles revDeps = - case cycles of - [] -> Nothing - c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c - where - cycles :: [[QPN]] - cycles = [vs | Gr.CyclicSCC vs <- scc] - - scc :: [SCC QPN] - scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps - - aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN]) - aux (fr, to) = (fr, fr, map snd to) diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Client.Dependency.Modular.Dependency ( - -- * Variables - Var(..) - , simplifyVar - , varPI - -- * Conflict sets - , ConflictSet - , CS.showCS - -- * Constrained instances - , CI(..) - , merge - -- * Flagged dependencies - , FlaggedDeps - , FlaggedDep(..) - , Dep(..) - , showDep - , flattenFlaggedDeps - , QualifyOptions(..) - , qualifyDeps - , unqualifyDeps - -- ** Setting/forgetting components - , forgetCompOpenGoal - , setCompFlaggedDeps - -- * Reverse dependency map - , RevDepMap - -- * Goals - , Goal(..) - , GoalReason(..) - , QGoalReason - , ResetVar(..) - , goalVarToConflictSet - , varToConflictSet - , goalReasonToVars - -- * Open goals - , OpenGoal(..) - , close - ) where - -import Prelude hiding (pi) - -import Data.Map (Map) -import qualified Data.List as L - -import Language.Haskell.Extension (Extension(..), Language(..)) - -import Distribution.Text - -import Distribution.Client.Dependency.Modular.ConflictSet (ConflictSet) -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Var -import Distribution.Client.Dependency.Modular.Version -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS - -import Distribution.Client.ComponentDeps (Component(..)) - -{------------------------------------------------------------------------------- - Constrained instances --------------------------------------------------------------------------------} - --- | Constrained instance. If the choice has already been made, this is --- a fixed instance, and we record the package name for which the choice --- is for convenience. Otherwise, it is a list of version ranges paired with --- the goals / variables that introduced them. -data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn] - deriving (Eq, Show, Functor) - -showCI :: CI QPN -> String -showCI (Fixed i _) = "==" ++ showI i -showCI (Constrained vr) = showVR (collapse vr) - --- | Merge constrained instances. We currently adopt a lazy strategy for --- merging, i.e., we only perform actual checking if one of the two choices --- is fixed. If the merge fails, we return a conflict set indicating the --- variables responsible for the failure, as well as the two conflicting --- fragments. --- --- Note that while there may be more than one conflicting pair of version --- ranges, we only return the first we find. --- --- TODO: Different pairs might have different conflict sets. We're --- obviously interested to return a conflict that has a "better" conflict --- set in the sense the it contains variables that allow us to backjump --- further. We might apply some heuristics here, such as to change the --- order in which we check the constraints. -merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn) -merge c@(Fixed i g1) d@(Fixed j g2) - | i == j = Right c - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d)) -merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... - where - go [] = Right c - go (d@(vr, g2) : vrs) - | checkVR vr v = go vrs - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d])) -merge c@(Constrained _) d@(Fixed _ _) = merge d c -merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) - -{------------------------------------------------------------------------------- - Flagged dependencies --------------------------------------------------------------------------------} - --- | Flagged dependencies --- --- 'FlaggedDeps' is the modular solver's view of a packages dependencies: --- rather than having the dependencies indexed by component, each dependency --- defines what component it is in. --- --- However, top-level goals are also modelled as dependencies, but of course --- these don't actually belong in any component of any package. Therefore, we --- parameterize 'FlaggedDeps' and derived datatypes with a type argument that --- specifies whether or not we have a component: we only ever instantiate this --- type argument with @()@ for top-level goals, or 'Component' for everything --- else (we could express this as a kind at the type-level, but that would --- require a very recent GHC). --- --- Note however, crucially, that independent of the type parameters, the list --- of dependencies underneath a flag choice or stanza choices _always_ uses --- Component as the type argument. This is important: when we pick a value for --- a flag, we _must_ know what component the new dependencies belong to, or --- else we don't be able to construct fine-grained reverse dependencies. -type FlaggedDeps comp qpn = [FlaggedDep comp qpn] - --- | Flagged dependencies can either be plain dependency constraints, --- or flag-dependent dependency trees. -data FlaggedDep comp qpn = - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - | Simple (Dep qpn) comp - deriving (Eq, Show) - --- | Conversatively flatten out flagged dependencies --- --- NOTE: We do not filter out duplicates. -flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)] -flattenFlaggedDeps = concatMap aux - where - aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)] - aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f - aux (Stanza _ t) = flattenFlaggedDeps t - aux (Simple d c) = [(d, c)] - -type TrueFlaggedDeps qpn = FlaggedDeps Component qpn -type FalseFlaggedDeps qpn = FlaggedDeps Component qpn - --- | A dependency (constraint) associates a package name with a --- constrained instance. --- --- 'Dep' intentionally has no 'Functor' instance because the type variable --- is used both to record the dependencies as well as who's doing the --- depending; having a 'Functor' instance makes bugs where we don't distinguish --- these two far too likely. (By rights 'Dep' ought to have two type variables.) -data Dep qpn = Dep qpn (CI qpn) -- dependency on a package - | Ext Extension -- dependency on a language extension - | Lang Language -- dependency on a language version - | Pkg PN VR -- dependency on a pkg-config package - deriving (Eq, Show) - -showDep :: Dep QPN -> String -showDep (Dep qpn (Fixed i v) ) = - (if P qpn /= v then showVar v ++ " => " else "") ++ - showQPN qpn ++ "==" ++ showI i -showDep (Dep qpn (Constrained [(vr, v)])) = - showVar v ++ " => " ++ showQPN qpn ++ showVR vr -showDep (Dep qpn ci ) = - showQPN qpn ++ showCI ci -showDep (Ext ext) = "requires " ++ display ext -showDep (Lang lang) = "requires " ++ display lang -showDep (Pkg pn vr) = "requires pkg-config package " - ++ display pn ++ display vr - ++ ", not found in the pkg-config database" - --- | Options for goal qualification (used in 'qualifyDeps') --- --- See also 'defaultQualifyOptions' -data QualifyOptions = QO { - -- | Do we have a version of base relying on another version of base? - qoBaseShim :: Bool - - -- Should dependencies of the setup script be treated as independent? - , qoSetupIndependent :: Bool - } - deriving Show - --- | Apply built-in rules for package qualifiers --- --- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', --- it is important that these 'QualifyOptions' are _static_. Qualification --- does NOT depend on flag assignment; in other words, it behaves the same no --- matter which choices the solver makes (modulo the global 'QualifyOptions'); --- we rely on this in 'linkDeps' (see comment there). --- --- NOTE: It's the _dependencies_ of a package that may or may not be independent --- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN -qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go - where - go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN - go = map go1 - - go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN - go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goD dep comp) comp - - -- Suppose package B has a setup dependency on package A. - -- This will be recorded as something like - -- - -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason]) - -- - -- Observe that when we qualify this dependency, we need to turn that - -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier - -- to the goal or the goal reason chain. - goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep ci) comp - | qBase dep = Dep (Q (PP ns (Base pn)) dep) (fmap (Q pp) ci) - | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci) - | otherwise = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci) - - -- If P has a setup dependency on Q, and Q has a regular dependency on R, then - -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup - -- dependency on R. We do not do this for the base qualifier however. - -- - -- The inherited qualifier is only used for regular dependencies; for setup - -- and base deppendencies we override the existing qualifier. See #3160 for - -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of - Setup _ -> q - Unqualified -> q - Base _ -> Unqualified - - -- Should we qualify this goal with the 'Base' package path? - qBase :: PN -> Bool - qBase dep = qoBaseShim && unPackageName dep == "base" - - -- Should we qualify this goal with the 'Setup' packaeg path? - qSetup :: Component -> Bool - qSetup comp = qoSetupIndependent && comp == ComponentSetup - --- | Remove qualifiers from set of dependencies --- --- This is used during link validation: when we link package @Q.A@ to @Q'.A@, --- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute --- what to link these dependencies to, we need to requalify @Q.B@ to become --- @Q'.B@; we do this by first removing all qualifiers and then calling --- 'qualifyDeps' again. -unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN -unqualifyDeps = go - where - go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN - go = map go1 - - go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN - go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goD dep) comp - - goD :: Dep QPN -> Dep PN - goD (Dep qpn ci) = Dep (unq qpn) (fmap unq ci) - goD (Ext ext) = Ext ext - goD (Lang lang) = Lang lang - goD (Pkg pn vr) = Pkg pn vr - - unq :: QPN -> PN - unq (Q _ pn) = pn - -{------------------------------------------------------------------------------- - Setting/forgetting the Component --------------------------------------------------------------------------------} - -forgetCompOpenGoal :: OpenGoal Component -> OpenGoal () -forgetCompOpenGoal = mapCompOpenGoal $ const () - -setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn -setCompFlaggedDeps = mapCompFlaggedDeps . const - -{------------------------------------------------------------------------------- - Auxiliary: Mapping over the Component goal - - We don't export these, because the only type instantiations for 'a' and 'b' - here should be () or Component. (We could express this at the type level - if we relied on newer versions of GHC.) --------------------------------------------------------------------------------} - -mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b -mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr - -mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn -mapCompFlaggedDeps = L.map . mapCompFlaggedDep - -mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn -mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo t f -mapCompFlaggedDep _ (Stanza sn t ) = Stanza sn t -mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a) - -{------------------------------------------------------------------------------- - Reverse dependency map --------------------------------------------------------------------------------} - --- | A map containing reverse dependencies between qualified --- package names. -type RevDepMap = Map QPN [(Component, QPN)] - -{------------------------------------------------------------------------------- - Goals --------------------------------------------------------------------------------} - --- | A goal is just a solver variable paired with a reason. --- The reason is only used for tracing. -data Goal qpn = Goal (Var qpn) (GoalReason qpn) - deriving (Eq, Show, Functor) - --- | Reason why a goal is being added to a goal set. -data GoalReason qpn = - UserGoal - | PDependency (PI qpn) - | FDependency (FN qpn) Bool - | SDependency (SN qpn) - deriving (Eq, Show, Functor) - -type QGoalReason = GoalReason QPN - -class ResetVar f where - resetVar :: Var qpn -> f qpn -> f qpn - -instance ResetVar CI where - resetVar v (Fixed i _) = Fixed i v - resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs) - -instance ResetVar Dep where - resetVar v (Dep qpn ci) = Dep qpn (resetVar v ci) - resetVar _ (Ext ext) = Ext ext - resetVar _ (Lang lang) = Lang lang - resetVar _ (Pkg pn vr) = Pkg pn vr - -instance ResetVar Var where - resetVar = const - --- | Compute a singleton conflict set from a goal, containing just --- the goal variable. --- --- NOTE: This is just a call to 'varToConflictSet' under the hood; --- the 'GoalReason' is ignored. -goalVarToConflictSet :: Goal qpn -> ConflictSet qpn -goalVarToConflictSet (Goal g _gr) = varToConflictSet g - --- | Compute a singleton conflict set from a 'Var' -varToConflictSet :: Var qpn -> ConflictSet qpn -varToConflictSet = CS.singleton - --- | A goal reason is mostly just a variable paired with the --- decision we made for that variable (except for user goals, --- where we cannot really point to a solver variable). This --- function drops the decision and recovers the list of --- variables (which will be empty or contain one element). --- -goalReasonToVars :: GoalReason qpn -> [Var qpn] -goalReasonToVars UserGoal = [] -goalReasonToVars (PDependency (PI qpn _)) = [P qpn] -goalReasonToVars (FDependency qfn _) = [F qfn] -goalReasonToVars (SDependency qsn) = [S qsn] - -{------------------------------------------------------------------------------- - Open goals --------------------------------------------------------------------------------} - --- | For open goals as they occur during the build phase, we need to store --- additional information about flags. -data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason - deriving (Eq, Show) - --- | Closes a goal, i.e., removes all the extraneous information that we --- need only during the build phase. -close :: OpenGoal comp -> Goal QPN -close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr -close (OpenGoal (Simple (Ext _) _) _ ) = - error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal" -close (OpenGoal (Simple (Lang _) _) _ ) = - error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal" -close (OpenGoal (Simple (Pkg _ _) _) _ ) = - error "Distribution.Client.Dependency.Modular.Dependency.close: called on Pkg goal" -close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr -close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr - -{------------------------------------------------------------------------------- - Version ranges paired with origins --------------------------------------------------------------------------------} - -type VROrigin qpn = (VR, Var qpn) - --- | Helper function to collapse a list of version ranges with origins into --- a single, simplified, version range. -collapse :: [VROrigin qpn] -> VR -collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Explore.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Distribution.Client.Dependency.Modular.Explore - ( backjump - , backjumpAndExplore - ) where - -import Data.Foldable as F -import Data.Map as M - -import Distribution.Client.Dependency.Modular.Assignment -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Log -import Distribution.Client.Dependency.Modular.Message -import Distribution.Client.Dependency.Modular.Package -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS -import Distribution.Client.Dependency.Modular.Tree -import qualified Distribution.Client.Dependency.Types as T - --- | This function takes the variable we're currently considering, an --- initial conflict set and a --- list of children's logs. Each log yields either a solution or a --- conflict set. The result is a combined log for the parent node that --- has explored a prefix of the children. --- --- We can stop traversing the children's logs if we find an individual --- conflict set that does not contain the current variable. In this --- case, we can just lift the conflict set to the current level, --- because the current level cannot possibly have contributed to this --- conflict, so no other choice at the current level would avoid the --- conflict. --- --- If any of the children might contain a successful solution, we can --- return it immediately. If all children contain conflict sets, we can --- take the union as the combined conflict set. --- --- The initial conflict set corresponds to the justification that we --- have to choose this goal at all. There is a reason why we have --- introduced the goal in the first place, and this reason is in conflict --- with the (virtual) option not to choose anything for the current --- variable. See also the comments for 'avoidSet'. --- -backjump :: F.Foldable t => Var QPN -> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a -backjump var initial xs = F.foldr combine logBackjump xs initial - where - combine :: ConflictSetLog a - -> (ConflictSet QPN -> ConflictSetLog a) - -> ConflictSet QPN -> ConflictSetLog a - combine (T.Done x) _ _ = T.Done x - combine (T.Fail cs) f csAcc - | not (var `CS.member` cs) = logBackjump cs - | otherwise = f (csAcc `CS.union` cs) - combine (T.Step m ms) f cs = T.Step m (combine ms f cs) - - logBackjump :: ConflictSet QPN -> ConflictSetLog a - logBackjump cs = failWith (Failure cs Backjump) cs - -type ConflictSetLog = T.Progress Message (ConflictSet QPN) - --- | A tree traversal that simultaneously propagates conflict sets up --- the tree from the leaves and creates a log. -exploreLog :: Tree QGoalReason -> (Assignment -> ConflictSetLog (Assignment, RevDepMap)) -exploreLog = cata go - where - go :: TreeF QGoalReason (Assignment -> ConflictSetLog (Assignment, RevDepMap)) - -> (Assignment -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) _ = failWith (Failure c fr) c - go (DoneF rdm) a = succeedWith Success (a, rdm) - go (PChoiceF qpn gr ts) (A pa fa sa) = - backjump (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - P.mapWithKey -- when descending ... - (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ... - r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice - ts - go (FChoiceF qfn gr _ _ ts) (A pa fa sa) = - backjump (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - P.mapWithKey -- when descending ... - (\ k r -> tryWith (TryF qfn k) $ -- log and ... - r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice - ts - go (SChoiceF qsn gr _ ts) (A pa fa sa) = - backjump (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - P.mapWithKey -- when descending ... - (\ k r -> tryWith (TryS qsn k) $ -- log and ... - r (A pa fa (M.insert qsn k sa))) -- record the pkg choice - ts - go (GoalChoiceF ts) a = - P.casePSQ ts - (failWith (Failure CS.empty EmptyGoalChoice) CS.empty) -- empty goal choice is an internal error - (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice - --- | Build a conflict set corresponding to the (virtual) option not to --- choose a solution for a goal at all. --- --- In the solver, the set of goals is not statically determined, but depends --- on the choices we make. Therefore, when dealing with conflict sets, we --- always have to consider that we could perhaps make choices that would --- avoid the existence of the goal completely. --- --- Whenever we actual introduce a choice in the tree, we have already established --- that the goal cannot be avoided. This is tracked in the "goal reason". --- The choice to avoid the goal therefore is a conflict between the goal itself --- and its goal reason. We build this set here, and pass it to the 'backjump' --- function as the initial conflict set. --- --- This has two effects: --- --- - In a situation where there are no choices available at all (this happens --- if an unknown package is requested), the initial conflict set becomes the --- actual conflict set. --- --- - In a situation where we backjump past the current node, the goal reason --- of the current node will be added to the conflict set. --- -avoidSet :: Var QPN -> QGoalReason -> ConflictSet QPN -avoidSet var gr = - CS.fromList (var : goalReasonToVars gr) - --- | Interface. -backjumpAndExplore :: Tree QGoalReason -> Log Message (Assignment, RevDepMap) -backjumpAndExplore t = toLog $ exploreLog t (A M.empty M.empty M.empty) - where - toLog :: T.Progress step fail done -> Log step done - toLog = T.foldProgress T.Step (const (T.Fail ())) T.Done diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.Dependency.Modular.Flag - ( FInfo(..) - , Flag - , FlagInfo - , FN(..) - , QFN - , QSN - , SN(..) - , mkFlag - , showFBool - , showQFN - , showQFNBool - , showQSN - , showQSNBool - ) where - -import Data.Map as M -import Prelude hiding (pi) - -import Distribution.PackageDescription hiding (Flag) -- from Cabal - -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Types (OptionalStanza(..)) - --- | Flag name. Consists of a package instance and the flag identifier itself. -data FN qpn = FN (PI qpn) Flag - deriving (Eq, Ord, Show, Functor) - --- | Flag identifier. Just a string. -type Flag = FlagName - -unFlag :: Flag -> String -unFlag (FlagName fn) = fn - -mkFlag :: String -> Flag -mkFlag fn = FlagName fn - --- | Flag info. Default value, whether the flag is manual, and --- whether the flag is weak. Manual flags can only be set explicitly. --- Weak flags are typically deferred by the solver. -data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool } - deriving (Eq, Ord, Show) - --- | Flag defaults. -type FlagInfo = Map Flag FInfo - --- | Qualified flag name. -type QFN = FN QPN - --- | Stanza name. Paired with a package name, much like a flag. -data SN qpn = SN (PI qpn) OptionalStanza - deriving (Eq, Ord, Show, Functor) - --- | Qualified stanza name. -type QSN = SN QPN - -unStanza :: OptionalStanza -> String -unStanza TestStanzas = "test" -unStanza BenchStanzas = "bench" - -showQFNBool :: QFN -> Bool -> String -showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b - -showQSNBool :: QSN -> Bool -> String -showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b - -showFBool :: FN qpn -> Bool -> String -showFBool (FN _ f) True = "+" ++ unFlag f -showFBool (FN _ f) False = "-" ++ unFlag f - -showSBool :: SN qpn -> Bool -> String -showSBool (SN _ s) True = "*" ++ unStanza s -showSBool (SN _ s) False = "!" ++ unStanza s - -showQFN :: QFN -> String -showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f - -showQSN :: QSN -> String -showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Index.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Distribution.Client.Dependency.Modular.Index - ( Index - , PInfo(..) - , defaultQualifyOptions - , mkIndex - ) where - -import Data.List as L -import Data.Map as M -import Prelude hiding (pi) - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree - -import Distribution.Client.ComponentDeps (Component) - --- | An index contains information about package instances. This is a nested --- dictionary. Package names are mapped to instances, which in turn is mapped --- to info. -type Index = Map PN (Map I PInfo) - --- | Info associated with a package instance. --- Currently, dependencies, flags and failure reasons. --- Packages that have a failure reason recorded for them are disabled --- globally, for reasons external to the solver. We currently use this --- for shadowing which essentially is a GHC limitation, and for --- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason) - deriving (Show) - -mkIndex :: [(PN, I, PInfo)] -> Index -mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) - -groupMap :: Ord a => [(a, b)] -> Map a [b] -groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) - -defaultQualifyOptions :: Index -> QualifyOptions -defaultQualifyOptions idx = QO { - qoBaseShim = or [ dep == base - | -- Find all versions of base .. - Just is <- [M.lookup base idx] - -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is - -- .. and flatten all their dependencies .. - , (Dep dep _ci, _comp) <- flattenFlaggedDeps deps - ] - , qoSetupIndependent = True - } - where - base = PackageName "base" diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ /dev/null @@ -1,219 +0,0 @@ -module Distribution.Client.Dependency.Modular.IndexConversion - ( convPIs - ) where - -import Data.List as L -import Data.Map as M -import Data.Maybe -import Data.Monoid as Mon -import Prelude hiding (pi) - -import qualified Distribution.Client.PackageIndex as CI -import Distribution.Client.Types -import Distribution.Client.ComponentDeps (Component(..)) -import Distribution.Compiler -import Distribution.InstalledPackageInfo as IPI -import Distribution.Package -- from Cabal -import Distribution.PackageDescription as PD -- from Cabal -import Distribution.PackageDescription.Configuration as PDC -import qualified Distribution.Simple.PackageIndex as SI -import Distribution.System - -import Distribution.Client.Dependency.Modular.Dependency as D -import Distribution.Client.Dependency.Modular.Flag as F -import Distribution.Client.Dependency.Modular.Index -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree -import Distribution.Client.Dependency.Modular.Version - --- | Convert both the installed package index and the source package --- index into one uniform solver index. --- --- We use 'allPackagesBySourcePackageId' for the installed package index --- because that returns us several instances of the same package and version --- in order of preference. This allows us in principle to \"shadow\" --- packages if there are several installed packages of the same version. --- There are currently some shortcomings in both GHC and Cabal in --- resolving these situations. However, the right thing to do is to --- fix the problem there, so for now, shadowing is only activated if --- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Bool -> Bool -> - SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> Index -convPIs os arch comp sip strfl iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sidx) - --- | Convert a Cabal installed package index to the simpler, --- more uniform index format of the solver. -convIPI' :: Bool -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] -convIPI' sip idx = - -- apply shadowing whenever there are multiple installed packages with - -- the same version - [ maybeShadow (convIP idx pkg) - | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx - , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] - where - - -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) - shadow x = x - --- | Convert a single installed package into the solver-specific format. -convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) -convIP idx ipi = - let ipid = IPI.installedUnitId ipi - i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) - pn = pkgName (sourcePackageId ipi) - in case mapM (convIPId pn idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing) - where - -- We assume that all dependencies of installed packages are _library_ deps - setComp = setCompFlaggedDeps ComponentLib --- TODO: Installed packages should also store their encapsulations! - --- | Convert dependencies specified by an installed package id into --- flagged dependencies of the solver. --- --- May return Nothing if the package can't be found in the index. That --- indicates that the original package having this dependency is broken --- and should be ignored. -convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) -convIPId pn' idx ipid = - case SI.lookupUnitId idx ipid of - Nothing -> Nothing - Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) - pn = pkgName (sourcePackageId ipi) - in Just (D.Simple (Dep pn (Fixed i (P pn'))) ()) - --- | Convert a cabal-install source package index to the simpler, --- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Bool -> - CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] -convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages - --- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage -> (PN, I, PInfo) -convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = - let i = I pv InRepo - in (pn, i, convGPD os arch cinfo strfl (PI pn i) gpd) - --- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' --- from 'Distribution.PackageDescription.Configuration' here, because we --- want to keep the condition tree, but simplify much of the test. - --- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> Bool -> - PI PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo strfl pi - (GenericPackageDescription pkg flags libs exes tests benchs) = - let - fds = flagInfo strfl flags - - conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN - conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo . - PDC.addBuildableCondition getInfo - in - PInfo - (maybe [] (conv ComponentLib libBuildInfo ) libs ++ - maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg) ++ - concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo ds) exes ++ - prefix (Stanza (SN pi TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo ds) tests) ++ - prefix (Stanza (SN pi BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)) - fds - Nothing - -prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn -prefix _ [] = [] -prefix f fds = [f (concat fds)] - --- | Convert flag information. Automatic flags are now considered weak --- unless strong flags have been selected explicitly. -flagInfo :: Bool -> [PD.Flag] -> FlagInfo -flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m)))) - --- | Convert condition trees to flagged dependencies. -convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> - Component -> - (a -> BuildInfo) -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN -convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo (CondNode info ds branches) = - L.map (\d -> D.Simple (convDep pn d) comp) ds -- unconditional package dependencies - ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies - ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch os arch cinfo pi fds comp getInfo) branches - where - bi = getInfo info - --- | Branch interpreter. --- --- Here, we try to simplify one of Cabal's condition tree branches into the --- solver's flagged dependency format, which is weaker. Condition trees can --- contain complex logical expression composed from flag choices and special --- flags (such as architecture, or compiler flavour). We try to evaluate the --- special flags and subsequently simplify to a tree that only depends on --- simple flag choices. -convBranch :: OS -> Arch -> CompilerInfo -> - PI PN -> FlagInfo -> - Component -> - (a -> BuildInfo) -> - (Condition ConfVar, - CondTree ConfVar [Dependency] a, - Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN -convBranch os arch cinfo pi@(PI pn _) fds comp getInfo (c', t', mf') = - go c' ( convCondTree os arch cinfo pi fds comp getInfo t') - (maybe [] (convCondTree os arch cinfo pi fds comp getInfo) mf') - where - go :: Condition ConfVar -> - FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN - go (Lit True) t _ = t - go (Lit False) _ f = f - go (CNot c) t f = go c f t - go (CAnd c d) t f = go c (go d t f) f - go (COr c d) t f = go c t (go d t f) - go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f] - go (Var (OS os')) t f - | os == os' = t - | otherwise = f - go (Var (Arch arch')) t f - | arch == arch' = t - | otherwise = f - go (Var (Impl cf cvr)) t f - | matchImpl (compilerInfoId cinfo) || - -- fixme: Nothing should be treated as unknown, rather than empty - -- list. This code should eventually be changed to either - -- support partial resolution of compiler flags or to - -- complain about incompletely configured compilers. - any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t - | otherwise = f - where - matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv - - -- If both branches contain the same package as a simple dep, we lift it to - -- the next higher-level, but without constraints. This heuristic together - -- with deferring flag choices will then usually first resolve this package, - -- and try an already installed version before imposing a default flag choice - -- that might not be what we want. - -- - -- Note that we make assumptions here on the form of the dependencies that - -- can occur at this point. In particular, no occurrences of Fixed, and no - -- occurrences of multiple version ranges, as all dependencies below this - -- point have been generated using 'convDep'. - extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN - extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp - | D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps - , D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps' - , pn1 == pn2 - ] - --- | Convert a Cabal dependency to a solver-specific dependency. -convDep :: PN -> Dependency -> Dep PN -convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, P pn')]) - --- | Convert setup dependencies -convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN -convSetupBuildInfo (PI pn _i) nfo = - L.map (\d -> D.Simple (convDep pn d) ComponentSetup) (PD.setupDepends nfo) diff --git a/Distribution/Client/Dependency/Modular/Linking.hs b/Distribution/Client/Dependency/Modular/Linking.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Linking.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Distribution.Client.Dependency.Modular.Linking ( - addLinking - , validateLinking - ) where - -import Prelude hiding (pi) -import Control.Exception (assert) -import Control.Monad.Reader -import Control.Monad.State -import Data.Maybe (catMaybes) -import Data.Map (Map, (!)) -import Data.List (intercalate) -import Data.Set (Set) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Traversable as T - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -import Distribution.Client.Dependency.Modular.Assignment -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Index -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS - -import Distribution.Client.Types (OptionalStanza(..)) -import Distribution.Client.ComponentDeps (Component) - -{------------------------------------------------------------------------------- - Add linking --------------------------------------------------------------------------------} - -type RelatedGoals = Map (PN, I) [PP] -type Linker = Reader RelatedGoals - --- | Introduce link nodes into tree tree --- --- Linking is a traversal of the solver tree that adapts package choice nodes --- and adds the option to link wherever appropriate: Package goals are called --- "related" if they are for the same version of the same package (but have --- different prefixes). A link option is available in a package choice node --- whenever we can choose an instance that has already been chosen for a related --- goal at a higher position in the tree. --- --- The code here proceeds by maintaining a finite map recording choices that --- have been made at higher positions in the tree. For each pair of package name --- and instance, it stores the prefixes at which we have made a choice for this --- package instance. Whenever we make a choice, we extend the map. Whenever we --- find a choice, we look into the map in order to find out what link options we --- have to add. -addLinking :: Tree QGoalReason -> Tree QGoalReason -addLinking = (`runReader` M.empty) . cata go - where - go :: TreeF QGoalReason (Linker (Tree QGoalReason)) -> Linker (Tree QGoalReason) - - -- The only nodes of interest are package nodes - go (PChoiceF qpn gr cs) = do - env <- ask - cs' <- T.sequence $ P.mapWithKey (goP qpn) cs - let newCs = concatMap (linkChoices env qpn) (P.toList cs') - return $ PChoice qpn gr (cs' `P.union` P.fromList newCs) - go _otherwise = - innM _otherwise - - -- Recurse underneath package choices. Here we just need to make sure - -- that we record the package choice so that it is available below - goP :: QPN -> POption -> Linker (Tree QGoalReason) -> Linker (Tree QGoalReason) - goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp]) - goP _ _ = alreadyLinked - -linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption, Tree QGoalReason)] -linkChoices related (Q _pp pn) (POption i Nothing, subtree) = - map aux (M.findWithDefault [] (pn, i) related) - where - aux :: PP -> (POption, Tree QGoalReason) - aux pp = (POption i (Just pp), subtree) -linkChoices _ _ (POption _ (Just _), _) = - alreadyLinked - -alreadyLinked :: a -alreadyLinked = error "addLinking called on tree that already contains linked nodes" - -{------------------------------------------------------------------------------- - Validation - - Validation of links is a separate pass that's performed after normal - validation. Validation of links checks that if the tree indicates that a - package is linked, then everything underneath that choice really matches the - package we have linked to. - - This is interesting because it isn't unidirectional. Consider that we've - chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. - Now foo depends on bar. Because a.foo and b.foo are linked, it's required that - a.bar and b.bar are also linked. However, it's not required that we actually - choose a.bar before b.bar. Goal choice order is relatively free. It's possible - that we choose a.bar first, but also possible that we choose b.bar first. In - both cases, we have to recognize that we have freedom of choice for the first - of the two, but no freedom of choice for the second. - - This is what LinkGroups are all about. Using LinkGroup, we can record (in the - situation above) that a.bar and b.bar need to be linked even if we haven't - chosen either of them yet. --------------------------------------------------------------------------------} - -data ValidateState = VS { - vsIndex :: Index - , vsLinks :: Map QPN LinkGroup - , vsFlags :: FAssignment - , vsStanzas :: SAssignment - , vsQualifyOptions :: QualifyOptions - } - deriving Show - -type Validate = Reader ValidateState - --- | Validate linked packages --- --- Verify that linked packages have --- --- * Linked dependencies, --- * Equal flag assignments --- * Equal stanza assignments -validateLinking :: Index -> Tree QGoalReason -> Tree QGoalReason -validateLinking index = (`runReader` initVS) . cata go - where - go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason) - - go (PChoiceF qpn gr cs) = - PChoice qpn gr <$> T.sequence (P.mapWithKey (goP qpn) cs) - go (FChoiceF qfn gr t m cs) = - FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs) - go (SChoiceF qsn gr t cs) = - SChoice qsn gr t <$> T.sequence (P.mapWithKey (goS qsn) cs) - - -- For the other nodes we just recurse - go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs - go (DoneF revDepMap) = return $ Done revDepMap - go (FailF conflictSet failReason) = return $ Fail conflictSet failReason - - -- Package choices - goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goP qpn@(Q _pp pn) opt@(POption i _) r = do - vs <- ask - let PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps - case execUpdateState (pickPOption qpn opt qdeps) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - -- Flag choices - goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goF qfn b r = do - vs <- ask - case execUpdateState (pickFlag qfn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - -- Stanza choices (much the same as flag choices) - goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goS qsn b r = do - vs <- ask - case execUpdateState (pickStanza qsn b) vs of - Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r - - initVS :: ValidateState - initVS = VS { - vsIndex = index - , vsLinks = M.empty - , vsFlags = M.empty - , vsStanzas = M.empty - , vsQualifyOptions = defaultQualifyOptions index - } - -{------------------------------------------------------------------------------- - Updating the validation state --------------------------------------------------------------------------------} - -type Conflict = (ConflictSet QPN, String) - -newtype UpdateState a = UpdateState { - unUpdateState :: StateT ValidateState (Either Conflict) a - } - deriving (Functor, Applicative, Monad) - -instance MonadState ValidateState UpdateState where - get = UpdateState $ get - put st = UpdateState $ do - assert (lgInvariant $ vsLinks st) $ return () - put st - -lift' :: Either Conflict a -> UpdateState a -lift' = UpdateState . lift - -conflict :: Conflict -> UpdateState a -conflict = lift' . Left - -execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState -execUpdateState = execStateT . unUpdateState - -pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState () -pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i -pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps - -pickConcrete :: QPN -> I -> UpdateState () -pickConcrete qpn@(Q pp _) i = do - vs <- get - case M.lookup qpn (vsLinks vs) of - -- Package is not yet in a LinkGroup. Create a new singleton link group. - Nothing -> do - let lg = lgSingleton qpn (Just $ PI pp i) - updateLinkGroup lg - - -- Package is already in a link group. Since we are picking a concrete - -- instance here, it must by definition be the canonical package. - Just lg -> - makeCanonical lg qpn i - -pickLink :: QPN -> I -> PP -> FlaggedDeps Component QPN -> UpdateState () -pickLink qpn@(Q _pp pn) i pp' deps = do - vs <- get - - -- The package might already be in a link group - -- (because one of its reverse dependencies is) - let lgSource = case M.lookup qpn (vsLinks vs) of - Nothing -> lgSingleton qpn Nothing - Just lg -> lg - - -- Find the link group for the package we are linking to - -- - -- Since the builder never links to a package without having first picked a - -- concrete instance for that package, and since we create singleton link - -- groups for concrete instances, this link group must exist (and must - -- in fact already have a canonical member). - let target = Q pp' pn - lgTarget = vsLinks vs ! target - - -- Verify here that the member we add is in fact for the same package and - -- matches the version of the canonical instance. However, violations of - -- these checks would indicate a bug in the linker, not a true conflict. - let sanityCheck :: Maybe (PI PP) -> Bool - sanityCheck Nothing = False - sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI - assert (sanityCheck (lgCanon lgTarget)) $ return () - - -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge [] lgSource lgTarget - updateLinkGroup lgTarget' - - -- Make sure all dependencies are linked as well - linkDeps target [P qpn] deps - -makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () -makeCanonical lg qpn@(Q pp _) i = - case lgCanon lg of - -- There is already a canonical member. Fail. - Just _ -> - conflict ( CS.insert (P qpn) (lgConflictSet lg) - , "cannot make " ++ showQPN qpn - ++ " canonical member of " ++ showLinkGroup lg - ) - Nothing -> do - let lg' = lg { lgCanon = Just (PI pp i) } - updateLinkGroup lg' - --- | Link the dependencies of linked parents. --- --- When we decide to link one package against another we walk through the --- package's direct depedencies and make sure that they're all linked to each --- other by merging their link groups (or creating new singleton link groups if --- they don't have link groups yet). We do not need to do this recursively, --- because having the direct dependencies in a link group means that we must --- have already made or will make sooner or later a link choice for one of these --- as well, and cover their dependencies at that point. -linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState () -linkDeps target = \blame deps -> do - -- linkDeps is called in two places: when we first link one package to - -- another, and when we discover more dependencies of an already linked - -- package after doing some flag assignment. It is therefore important that - -- flag assignments cannot influence _how_ dependencies are qualified; - -- fortunately this is a documented property of 'qualifyDeps'. - rdeps <- requalify deps - go blame deps rdeps - where - go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState () - go = zipWithM_ . go1 - - go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState () - go1 blame dep rdep = case (dep, rdep) of - (Simple (Dep qpn _) _, ~(Simple (Dep qpn' _) _)) -> do - vs <- get - let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs - lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge blame lg lg' - updateLinkGroup lg'' - (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do - vs <- get - case M.lookup fn (vsFlags vs) of - Nothing -> return () -- flag assignment not yet known - Just True -> go (F fn:blame) t t' - Just False -> go (F fn:blame) f f' - (Stanza sn t, ~(Stanza _ t')) -> do - vs <- get - case M.lookup sn (vsStanzas vs) of - Nothing -> return () -- stanza assignment not yet known - Just True -> go (S sn:blame) t t' - Just False -> return () -- stanza not enabled; no new deps - -- For extensions and language dependencies, there is nothing to do. - -- No choice is involved, just checking, so there is nothing to link. - -- The same goes for for pkg-config constraints. - (Simple (Ext _) _, _) -> return () - (Simple (Lang _) _, _) -> return () - (Simple (Pkg _ _) _, _) -> return () - - requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN) - requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) - -pickFlag :: QFN -> Bool -> UpdateState () -pickFlag qfn b = do - modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } - verifyFlag qfn - linkNewDeps (F qfn) b - -pickStanza :: QSN -> Bool -> UpdateState () -pickStanza qsn b = do - modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } - verifyStanza qsn - linkNewDeps (S qsn) b - --- | Link dependencies that we discover after making a flag choice. --- --- When we make a flag choice for a package, then new dependencies for that --- package might become available. If the package under consideration is in a --- non-trivial link group, then these new dependencies have to be linked as --- well. In linkNewDeps, we compute such new dependencies and make sure they are --- linked. -linkNewDeps :: Var QPN -> Bool -> UpdateState () -linkNewDeps var b = do - vs <- get - let (qpn@(Q pp pn), Just i) = varPI var - PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps - lg = vsLinks vs ! qpn - (parents, newDeps) = findNewDeps vs qdeps - linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps - where - findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps vs = concatMapUnzip (findNewDeps' vs) - - findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps' _ (Simple _ _) = ([], []) - findNewDeps' vs (Flagged qfn _ t f) = - case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> ([F qfn], if b then t else f) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f) - in (F qfn:parents, deps) - findNewDeps' vs (Stanza qsn t) = - case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> ([S qsn], if b then t else []) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else []) - in (S qsn:parents, deps) - -updateLinkGroup :: LinkGroup -> UpdateState () -updateLinkGroup lg = do - verifyLinkGroup lg - modify $ \vs -> vs { - vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) - `M.union` vsLinks vs - } - where - aux pp = (Q pp (lgPackage lg), lg) - -{------------------------------------------------------------------------------- - Verification --------------------------------------------------------------------------------} - -verifyLinkGroup :: LinkGroup -> UpdateState () -verifyLinkGroup lg = - case lgInstance lg of - -- No instance picked yet. Nothing to verify - Nothing -> - return () - - -- We picked an instance. Verify flags and stanzas - -- TODO: The enumeration of OptionalStanza names is very brittle; - -- if a constructor is added to the datatype we won't notice it here - Just i -> do - vs <- get - let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i - flags = M.keys finfo - stanzas = [TestStanzas, BenchStanzas] - forM_ flags $ \fn -> do - let flag = FN (PI (lgPackage lg) i) fn - verifyFlag' flag lg - forM_ stanzas $ \sn -> do - let stanza = SN (PI (lgPackage lg) i) sn - verifyStanza' stanza lg - -verifyFlag :: QFN -> UpdateState () -verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do - vs <- get - -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn) - -verifyStanza :: QSN -> UpdateState () -verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do - vs <- get - -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn) - --- | Verify that all packages in the link group agree on flag assignments --- --- For the given flag and the link group, obtain all assignments for the flag --- that have already been made for link group members, and check that they are --- equal. -verifyFlag' :: FN PN -> LinkGroup -> UpdateState () -verifyFlag' (FN (PI pn i) fn) lg = do - vs <- get - let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsFlags vs) flags - if allEqual (catMaybes vals) -- We ignore not-yet assigned flags - then return () - else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg - , "flag " ++ show fn ++ " incompatible" - ) - --- | Verify that all packages in the link group agree on stanza assignments --- --- For the given stanza and the link group, obtain all assignments for the --- stanza that have already been made for link group members, and check that --- they are equal. --- --- This function closely mirrors 'verifyFlag''. -verifyStanza' :: SN PN -> LinkGroup -> UpdateState () -verifyStanza' (SN (PI pn i) sn) lg = do - vs <- get - let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg)) - vals = map (`M.lookup` vsStanzas vs) stanzas - if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas - then return () - else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg - , "stanza " ++ show sn ++ " incompatible" - ) - -{------------------------------------------------------------------------------- - Link groups --------------------------------------------------------------------------------} - --- | Set of packages that must be linked together --- --- A LinkGroup is between several qualified package names. In the validation --- state, we maintain a map vsLinks from qualified package names to link groups. --- There is an invariant that for all members of a link group, vsLinks must map --- to the same link group. The function updateLinkGroup can be used to --- re-establish this invariant after creating or expanding a LinkGroup. -data LinkGroup = LinkGroup { - -- | The name of the package of this link group - lgPackage :: PN - - -- | The canonical member of this link group (the one where we picked - -- a concrete instance). Once we have picked a canonical member, all - -- other packages must link to this one. - -- - -- We may not know this yet (if we are constructing link groups - -- for dependencies) - , lgCanon :: Maybe (PI PP) - - -- | The members of the link group - , lgMembers :: Set PP - - -- | The set of variables that should be added to the conflict set if - -- something goes wrong with this link set (in addition to the members - -- of the link group itself) - , lgBlame :: ConflictSet QPN - } - deriving (Show, Eq) - --- | Invariant for the set of link groups: every element in the link group --- must be pointing to the /same/ link group -lgInvariant :: Map QPN LinkGroup -> Bool -lgInvariant links = all invGroup (M.elems links) - where - invGroup :: LinkGroup -> Bool - invGroup lg = allEqual $ map (`M.lookup` links) members - where - members :: [QPN] - members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) - --- | Package version of this group --- --- This is only known once we have picked a canonical element. -lgInstance :: LinkGroup -> Maybe I -lgInstance = fmap (\(PI _ i) -> i) . lgCanon - -showLinkGroup :: LinkGroup -> String -showLinkGroup lg = - "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" - where - showMember :: PP -> String - showMember pp = case lgCanon lg of - Just (PI pp' _i) | pp == pp' -> "*" - _otherwise -> "" - ++ case lgInstance lg of - Nothing -> showQPN (qpn pp) - Just i -> showPI (PI (qpn pp) i) - - qpn :: PP -> QPN - qpn pp = Q pp (lgPackage lg) - --- | Creates a link group that contains a single member. -lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup -lgSingleton (Q pp pn) canon = LinkGroup { - lgPackage = pn - , lgCanon = canon - , lgMembers = S.singleton pp - , lgBlame = CS.empty - } - -lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup -lgMerge blame lg lg' = do - canon <- pick (lgCanon lg) (lgCanon lg') - return LinkGroup { - lgPackage = lgPackage lg - , lgCanon = canon - , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg'] - } - where - pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) - pick Nothing Nothing = Right Nothing - pick (Just x) Nothing = Right $ Just x - pick Nothing (Just y) = Right $ Just y - pick (Just x) (Just y) = - if x == y then Right $ Just x - else Left ( CS.unions [ - CS.fromList blame - , lgConflictSet lg - , lgConflictSet lg' - ] - , "cannot merge " ++ showLinkGroup lg - ++ " and " ++ showLinkGroup lg' - ) - -lgConflictSet :: LinkGroup -> ConflictSet QPN -lgConflictSet lg = - CS.fromList (map aux (S.toList (lgMembers lg))) - `CS.union` lgBlame lg - where - aux pp = P (Q pp (lgPackage lg)) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual [_] = True -allEqual (x:y:ys) = x == y && allEqual (y:ys) - -concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c]) -concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Log.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Distribution.Client.Dependency.Modular.Log - ( Log - , continueWith - , failWith - , logToProgress - , succeedWith - , tryWith - ) where - -import Control.Applicative -import Data.List as L -import Data.Maybe (isNothing) - -import Distribution.Client.Dependency.Types -- from Cabal - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Message -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree (FailReason(..)) -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS - --- | The 'Log' datatype. --- --- Represents the progress of a computation lazily. --- --- Parameterized over the type of actual messages and the final result. -type Log m a = Progress m () a - -messages :: Progress step fail done -> [step] -messages = foldProgress (:) (const []) (const []) - --- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. --- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the --- limit is 'Just 0', backtracking is completely disabled. -logToProgress :: Maybe Int -> Log Message a -> Progress String String a -logToProgress mbj l = let - es = proc (Just 0) l -- catch first error (always) - ms = useFirstError (proc mbj l) - in go es es -- trace for first error - (showMessages (const True) True ms) -- run with backjump limit applied - where - -- Proc takes the allowed number of backjumps and a 'Progress' and explores the - -- messages until the maximum number of backjumps has been reached. It filters out - -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates - -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the - -- original success result or replaces the original failure with 'Nothing'. - proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b - proc _ (Done x) = Done x - proc _ (Fail _) = Fail Nothing - proc mbj' (Step (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _))) - | cs == cs' = proc mbj' xs -- repeated backjumps count as one - proc (Just 0) (Step (Failure cs Backjump) _) = Fail (Just cs) - proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs) - proc mbj' (Step x xs) = Step x (proc mbj' xs) - - -- Sets the conflict set from the first backjump as the final error, and records - -- whether the search was exhaustive. - useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b - -> Progress Message (Bool, Maybe (ConflictSet QPN)) b - useFirstError = replace Nothing - where - replace _ (Done x) = Done x - replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached. - -- Prefer first error over later error. - Fail (isNothing cs, cs' <|> cs) - replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs - replace cs' (Step x xs) = Step x $ replace cs' xs - - -- The first two arguments are both supposed to be the log up to the first error. - -- That's the error that will always be printed in case we do not find a solution. - -- We pass this log twice, because we evaluate it in parallel with the full log, - -- but we also want to retain the reference to its beginning for when we print it. - -- This trick prevents a space leak! - -- - -- The third argument is the full log, ending with either the solution or the - -- exhaustiveness and first conflict set. - go :: Progress Message a b - -> Progress Message a b - -> Progress String (Bool, Maybe (ConflictSet QPN)) b - -> Progress String String b - go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs) - go ms r (Step x xs) = Step x (go ms r xs) - go ms _ (Fail (exh, Just cs)) = Fail $ - "Could not resolve dependencies:\n" ++ - unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++ - (if exh then "Dependency tree exhaustively searched.\n" - else "Backjump limit reached (" ++ currlimit mbj ++ - "change with --max-backjumps or try to run with --reorder-goals).\n") - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" - go _ _ (Done s) = Done s - go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen - -failWith :: step -> fail -> Progress step fail done -failWith s f = Step s (Fail f) - -succeedWith :: step -> done -> Progress step fail done -succeedWith s d = Step s (Done d) - -continueWith :: step -> Progress step fail done -> Progress step fail done -continueWith = Step - -tryWith :: Message - -> Progress Message fail done - -> Progress Message fail done -tryWith m = Step m . Step Enter . foldProgress Step (failWith Leave) Done diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Message.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Distribution.Client.Dependency.Modular.Message ( - Message(..), - showMessages - ) where - -import qualified Data.List as L -import Prelude hiding (pi) - -import Distribution.Text -- from Cabal - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.Tree - ( FailReason(..), POption(..) ) -import Distribution.Client.Dependency.Types - ( ConstraintSource(..), showConstraintSource, Progress(..) ) - -data Message = - Enter -- ^ increase indentation level - | Leave -- ^ decrease indentation level - | TryP QPN POption - | TryF QFN Bool - | TryS QSN Bool - | Next (Goal QPN) - | Success - | Failure (ConflictSet QPN) FailReason - --- | Transforms the structured message type to actual messages (strings). --- --- Takes an additional relevance predicate. The predicate gets a stack of goal --- variables and can decide whether messages regarding these goals are relevant. --- You can plug in 'const True' if you're interested in a full trace. If you --- want a slice of the trace concerning a particular conflict set, then plug in --- a predicate returning 'True' on the empty stack and if the head is in the --- conflict set. --- --- The second argument indicates if the level numbers should be shown. This is --- recommended for any trace that involves backtracking, because only the level --- numbers will allow to keep track of backjumps. -showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b -showMessages p sl = go [] 0 - where - -- The stack 'v' represents variables that are currently assigned by the - -- solver. 'go' pushes a variable for a recursive call when it encounters - -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'. - -- When 'go' processes a package goal, or a package goal followed by a - -- 'Failure', it calls 'atLevel' with the goal variable at the head of the - -- stack so that the predicate can also select messages relating to package - -- goal choices. - go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b - go !_ !_ (Done x) = Done x - go !_ !_ (Fail x) = Fail x - -- complex patterns - go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - goPReject v l qpn [i] c fr ms - go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) - go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms - -- the previous case potentially arises in the error output, because we remove the backjump itself - -- if we cut the log after the first error - go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms - go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = - let v' = add (P qpn) v - in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms) - go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) - | c == c' = go v l ms - -- standard display - go !v !l (Step Enter ms) = go v (l+1) ms - go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms - go !v !l (Step (TryP qpn i) ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms) - go !v !l (Step (TryF qfn b) ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) - go !v !l (Step (TryS qsn b) ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms) - go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log - go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms) - go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms) - - showPackageGoal :: QPN -> QGoalReason -> String - showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr - - showFailure :: ConflictSet QPN -> FailReason -> String - showFailure c fr = "fail" ++ showFR c fr - - add :: Var QPN -> [Var QPN] -> [Var QPN] - add v vs = simplifyVar v : vs - - -- special handler for many subsequent package rejections - goPReject :: [Var QPN] - -> Int - -> QPN - -> [POption] - -> ConflictSet QPN - -> FailReason - -> Progress Message a b - -> Progress String a b - goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) - | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms - goPReject v l qpn is c fr ms = - (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms) - - -- write a message, but only if it's relevant; we can also enable or disable the display of the current level - atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b - atLevel v l x xs - | sl && p v = let s = show l - in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs - | p v = Step x xs - | otherwise = xs - -showQPNPOpt :: QPN -> POption -> String -showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = - case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption - Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) - -showGR :: QGoalReason -> String -showGR UserGoal = " (user goal)" -showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" -showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" -showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" - -showFR :: ConflictSet QPN -> FailReason -> String -showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" -showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" -showFR _ CannotInstall = " (only already installed instances can be used)" -showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" -showFR _ Shadowed = " (shadowed by another installed package with same version)" -showFR _ Broken = " (package is broken)" -showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")" -showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" -showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" -showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" -showFR _ ManualFlag = " (manual flag can only be changed explicitly)" -showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" -showFR _ MultipleInstances = " (multiple instances)" -showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")" -showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")" --- The following are internal failures. They should not occur. In the --- interest of not crashing unnecessarily, we still just print an error --- message though. -showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" -showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" -showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" - -constraintSource :: ConstraintSource -> String -constraintSource src = "constraint from " ++ showConstraintSource src diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/PSQ.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Client.Dependency.Modular.PSQ - ( PSQ(..) -- Unit test needs constructor access - , Degree(..) - , casePSQ - , cons - , degree - , delete - , dminimumBy - , length - , lookup - , filter - , filterKeys - , firstOnly - , fromList - , isZeroOrOne - , keys - , map - , mapKeys - , mapWithKey - , mapWithKeyState - , minimumBy - , null - , prefer - , preferByKeys - , preferOrElse - , snoc - , sortBy - , sortByKeys - , splits - , toList - , union - ) where - --- Priority search queues. --- --- I am not yet sure what exactly is needed. But we need a data structure with --- key-based lookup that can be sorted. We're using a sequence right now with --- (inefficiently implemented) lookup, because I think that queue-based --- operations and sorting turn out to be more efficiency-critical in practice. - -import Control.Arrow (first, second) - -import qualified Data.Foldable as F -import Data.Function -import qualified Data.List as S -import Data.Ord (comparing) -import Data.Traversable -import Prelude hiding (foldr, length, lookup, filter, null, map) - -newtype PSQ k v = PSQ [(k, v)] - deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP - -keys :: PSQ k v -> [k] -keys (PSQ xs) = fmap fst xs - -lookup :: Eq k => k -> PSQ k v -> Maybe v -lookup k (PSQ xs) = S.lookup k xs - -map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 -map f (PSQ xs) = PSQ (fmap (second f) xs) - -mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v -mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) - -mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b -mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) - -mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b -mapWithKeyState p (PSQ xs) s0 = - PSQ (F.foldr (\ (k, v) r s -> case p s k v of - (w, n) -> (k, w) : (r n)) - (const []) xs s0) - -delete :: Eq k => k -> PSQ k a -> PSQ k a -delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs)) - -fromList :: [(k, a)] -> PSQ k a -fromList = PSQ - -cons :: k -> a -> PSQ k a -> PSQ k a -cons k x (PSQ xs) = PSQ ((k, x) : xs) - -snoc :: PSQ k a -> k -> a -> PSQ k a -snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) - -casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r -casePSQ (PSQ xs) n c = - case xs of - [] -> n - (k, v) : ys -> c k v (PSQ ys) - -splits :: PSQ k a -> PSQ k (a, PSQ k a) -splits = go id - where - go f xs = casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys)) - -sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a -sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) - -sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a -sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) - --- | Given a measure in form of a pseudo-peano-natural number, --- determine the approximate minimum. This is designed to stop --- even traversing the list as soon as we find any element with --- measure 'ZeroOrOne'. --- --- Always returns a one-element queue (except if the queue is --- empty, then we return an empty queue again). --- -dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a -dminimumBy _ (PSQ []) = PSQ [] -dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs - where - go ZeroOrOne v _ = PSQ [v] - go _ v [] = PSQ [v] - go c v (y : ys) = case compare c d of - LT -> go c v ys - EQ -> go c v ys - GT -> go d y ys - where - d = sel (snd y) - -minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a -minimumBy sel (PSQ xs) = - PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] - --- | Will partition the list according to the predicate. If --- there is any element that satisfies the precidate, then only --- the elements satisfying the predicate are returned. --- Otherwise, the rest is returned. --- -prefer :: (a -> Bool) -> PSQ k a -> PSQ k a -prefer p (PSQ xs) = - let - (pro, con) = S.partition (p . snd) xs - in - if S.null pro then PSQ con else PSQ pro - --- | Variant of 'prefer' that takes a continuation for the case --- that there are none of the desired elements. -preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a -preferOrElse p k (PSQ xs) = - let - (pro, con) = S.partition (p . snd) xs - in - if S.null pro then k (PSQ con) else PSQ pro - --- | Variant of 'prefer' that takes a predicate on the keys --- rather than on the values. --- -preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -preferByKeys p (PSQ xs) = - let - (pro, con) = S.partition (p . fst) xs - in - if S.null pro then PSQ con else PSQ pro - -filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) - -filter :: (a -> Bool) -> PSQ k a -> PSQ k a -filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) - -length :: PSQ k a -> Int -length (PSQ xs) = S.length xs - --- | Approximation of the branching degree. --- --- This is designed for computing the branching degree of a goal choice --- node. If the degree is 0 or 1, it is always good to take that goal, --- because we can either abort immediately, or have no other choice anyway. --- --- So we do not actually want to compute the full degree (which is --- somewhat costly) in cases where we have such an easy choice. --- -data Degree = ZeroOrOne | Two | Other - deriving (Show, Eq) - -instance Ord Degree where - compare ZeroOrOne _ = LT -- lazy approximation - compare _ ZeroOrOne = GT -- approximation - compare Two Two = EQ - compare Two Other = LT - compare Other Two = GT - compare Other Other = EQ - -degree :: PSQ k a -> Degree -degree (PSQ []) = ZeroOrOne -degree (PSQ [_]) = ZeroOrOne -degree (PSQ [_, _]) = Two -degree (PSQ _) = Other - -null :: PSQ k a -> Bool -null (PSQ xs) = S.null xs - -isZeroOrOne :: PSQ k a -> Bool -isZeroOrOne (PSQ []) = True -isZeroOrOne (PSQ [_]) = True -isZeroOrOne _ = False - -firstOnly :: PSQ k a -> PSQ k a -firstOnly (PSQ []) = PSQ [] -firstOnly (PSQ (x : _)) = PSQ [x] - -toList :: PSQ k a -> [(k, a)] -toList (PSQ xs) = xs - -union :: PSQ k a -> PSQ k a -> PSQ k a -union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/Distribution/Client/Dependency/Modular/Package.hs b/Distribution/Client/Dependency/Modular/Package.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Package.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.Dependency.Modular.Package - ( I(..) - , Loc(..) - , PackageId - , PackageIdentifier(..) - , PackageName(..) - , PI(..) - , PN - , PP(..) - , Namespace(..) - , Qualifier(..) - , QPN - , QPV - , Q(..) - , instI - , makeIndependent - , primaryPP - , showI - , showPI - , showQPN - , unPN - ) where - -import Data.List as L - -import Distribution.Package -- from Cabal -import Distribution.Text -- from Cabal - -import Distribution.Client.Dependency.Modular.Version - --- | A package name. -type PN = PackageName - --- | Unpacking a package name. -unPN :: PN -> String -unPN (PackageName pn) = pn - --- | Package version. A package name plus a version number. -type PV = PackageId - --- | Qualified package version. -type QPV = Q PV - --- | Package id. Currently just a black-box string. -type PId = UnitId - --- | Location. Info about whether a package is installed or not, and where --- exactly it is located. For installed packages, uniquely identifies the --- package instance via its 'PId'. --- --- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo - deriving (Eq, Ord, Show) - --- | Instance. A version number and a location. -data I = I Ver Loc - deriving (Eq, Ord, Show) - --- | String representation of an instance. -showI :: I -> String -showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid - where - -- A hack to extract the beginning of the package ABI hash - shortId (SimpleUnitId (ComponentId i)) - = snip (splitAt 4) (++ "...") - . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) - $ i - snip p f xs = case p xs of - (ys, zs) -> (if L.null zs then id else f) ys - --- | Package instance. A package name and an instance. -data PI qpn = PI qpn I - deriving (Eq, Ord, Show, Functor) - --- | String representation of a package instance. -showPI :: PI QPN -> String -showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i - -instI :: I -> Bool -instI (I _ (Inst _)) = True -instI _ = False - --- | A package path consists of a namespace and a package path inside that --- namespace. -data PP = PP Namespace Qualifier - deriving (Eq, Ord, Show) - --- | Top-level namespace --- --- Package choices in different namespaces are considered completely independent --- by the solver. -data Namespace = - -- | The default namespace - DefaultNamespace - - -- | Independent namespace - -- - -- For now we just number these (rather than giving them more structure). - | Independent Int - deriving (Eq, Ord, Show) - --- | Qualifier of a package within a namespace (see 'PP') -data Qualifier = - -- | Top-level dependency in this namespace - Unqualified - - -- | Any dependency on base is considered independent - -- - -- This makes it possible to have base shims. - | Base PN - - -- | Setup dependency - -- - -- By rights setup dependencies ought to be nestable; after all, the setup - -- dependencies of a package might themselves have setup dependencies, which - -- are independent from everything else. However, this very quickly leads to - -- infinite search trees in the solver. Therefore we limit ourselves to - -- a single qualifier (within a given namespace). - | Setup PN - deriving (Eq, Ord, Show) - --- | Is the package in the primary group of packages. In particular this --- does not include packages pulled in as setup deps. --- -primaryPP :: PP -> Bool -primaryPP (PP _ns q) = go q - where - go Unqualified = True - go (Base _) = True - go (Setup _) = False - --- | String representation of a package path. --- --- NOTE: The result of 'showPP' is either empty or results in a period, so that --- it can be prepended to a package name. -showPP :: PP -> String -showPP (PP ns q) = - case ns of - DefaultNamespace -> go q - Independent i -> show i ++ "." ++ go q - where - -- Print the qualifier - -- - -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is - -- there to make sure different dependencies on base are all independent. - -- So we want to print something like @"A.base"@, where the @"A."@ part - -- is the qualifier and @"base"@ is the actual dependency (which, for the - -- 'Base' qualifier, will always be @base@). - go Unqualified = "" - go (Setup pn) = display pn ++ "-setup." - go (Base pn) = display pn ++ "." - --- | A qualified entity. Pairs a package path with the entity. -data Q a = Q PP a - deriving (Eq, Ord, Show) - --- | Standard string representation of a qualified entity. -showQ :: (a -> String) -> (Q a -> String) -showQ showa (Q pp x) = showPP pp ++ showa x - --- | Qualified package name. -type QPN = Q PN - --- | String representation of a qualified package path. -showQPN :: QPN -> String -showQPN = showQ display - --- | Create artificial parents for each of the package names, making --- them all independent. -makeIndependent :: [PN] -> [QPN] -makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] - , let pp = PP (Independent i) Unqualified - ] diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Preference.hs +++ /dev/null @@ -1,397 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Client.Dependency.Modular.Preference - ( avoidReinstalls - , deferSetupChoices - , deferWeakFlagChoices - , enforceManualFlags - , enforcePackageConstraints - , enforceSingleInstanceRestriction - , firstGoal - , preferBaseGoalChoice - , preferEasyGoalChoices - , preferLinked - , preferPackagePreferences - , preferReallyEasyGoalChoices - , requireInstalled - ) where - --- Reordering or pruning the tree in order to prefer or make certain choices. - -import qualified Data.List as L -import qualified Data.Map as M -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -import Control.Applicative -#endif -import Prelude hiding (sequence) -import Control.Monad.Reader hiding (sequence) -import Data.Map (Map) -import Data.Traversable (sequence) - -import Distribution.Client.Dependency.Types - ( PackageConstraint(..), LabeledPackageConstraint(..), ConstraintSource(..) - , PackagePreferences(..), InstalledPreference(..) ) -import Distribution.Client.Types - ( OptionalStanza(..) ) - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import Distribution.Client.Dependency.Modular.Tree -import Distribution.Client.Dependency.Modular.Version -import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS - --- | Generic abstraction for strategies that just rearrange the package order. --- Only packages that match the given predicate are reordered. -packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a -packageOrderFor p cmp' = trav go - where - go (PChoiceF v@(Q _ pn) r cs) - | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) - | otherwise = PChoiceF v r cs - go x = x - - cmp :: PN -> POption -> POption -> Ordering - cmp pn (POption i _) (POption i' _) = cmp' pn i i' - --- | Prefer to link packages whenever possible -preferLinked :: Tree a -> Tree a -preferLinked = trav go - where - go (PChoiceF qn a cs) = PChoiceF qn a (P.sortByKeys cmp cs) - go x = x - - cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo' - - cmpL Nothing Nothing = EQ - cmpL Nothing (Just _) = GT - cmpL (Just _) Nothing = LT - cmpL (Just _) (Just _) = EQ - --- | Ordering that treats versions satisfying more preferred ranges as greater --- than versions satisfying less preferred ranges. -preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering -preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2) - where - check v = Prelude.length . Prelude.filter (==True) . - Prelude.map (flip checkVR v) $ vrs - --- | Traversal that tries to establish package preferences (not constraints). --- Works by reordering choice nodes. Also applies stanza preferences. -preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a -preferPackagePreferences pcs = preferPackageStanzaPreferences pcs - . packageOrderFor (const True) preference - where - preference pn i1@(I v1 _) i2@(I v2 _) = - let PackagePreferences vrs ipref _ = pcs pn - in preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically - locationsOrdering ipref i1 i2 - - -- Note that we always rank installed before uninstalled, and later - -- versions before earlier, but we can change the priority of the - -- two orderings. - locationsOrdering PreferInstalled v1 v2 = - preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2 - locationsOrdering PreferLatest v1 v2 = - preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2 - --- | Ordering that treats installed instances as greater than uninstalled ones. -preferInstalledOrdering :: I -> I -> Ordering -preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ -preferInstalledOrdering (I _ (Inst _)) _ = GT -preferInstalledOrdering _ (I _ (Inst _)) = LT -preferInstalledOrdering _ _ = EQ - --- | Compare instances by their version numbers. -preferLatestOrdering :: I -> I -> Ordering -preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 - --- | Traversal that tries to establish package stanza enable\/disable --- preferences. Works by reordering the branches of stanza choices. -preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a -preferPackageStanzaPreferences pcs = trav go - where - go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) | primaryPP pp = - let PackagePreferences _ _ spref = pcs pn - enableStanzaPref = s `elem` spref - -- move True case first to try enabling the stanza - ts' | enableStanzaPref = P.sortByKeys (flip compare) ts - | otherwise = ts - in SChoiceF qsn gr True ts' -- True: now weak choice - go x = x - --- | Helper function that tries to enforce a single package constraint on a --- given instance for a P-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintP :: PP - -> ConflictSet QPN - -> I - -> LabeledPackageConstraint - -> Tree a - -> Tree a -processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r - | src == ConstraintSourceUserTarget && not (primaryPP pp) = r - -- the constraints arising from targets, like "foo-1.0" only apply to - -- the main packages in the solution, they don't constrain setup deps - -processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc - where - go (I v _) (PackageConstraintVersion _ vr) - | checkVR vr v = r - | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ (PackageConstraintInstalled _) - | instI i = r - | otherwise = Fail c (GlobalConstraintInstalled src) - go _ (PackageConstraintSource _) - | not (instI i) = r - | otherwise = Fail c (GlobalConstraintSource src) - go _ _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintF :: Flag - -> ConflictSet QPN - -> Bool - -> LabeledPackageConstraint - -> Tree a - -> Tree a -processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc - where - go (PackageConstraintFlags _ fa) = - case L.lookup f fa of - Nothing -> r - Just b | b == b' -> r - | otherwise -> Fail c (GlobalConstraintFlag src) - go _ = r - --- | Helper function that tries to enforce a single package constraint on a --- given flag setting for an F-node. Translates the constraint into a --- tree-transformer that either leaves the subtree untouched, or replaces it --- with an appropriate failure node. -processPackageConstraintS :: OptionalStanza - -> ConflictSet QPN - -> Bool - -> LabeledPackageConstraint - -> Tree a - -> Tree a -processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc - where - go (PackageConstraintStanzas _ ss) = - if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) - else r - go _ = r - --- | Traversal that tries to establish various kinds of user constraints. Works --- by selectively disabling choices that have been ruled out by global user --- constraints. -enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] - -> Tree QGoalReason - -> Tree QGoalReason -enforcePackageConstraints pcs = trav go - where - go (PChoiceF qpn@(Q pp pn) gr ts) = - let c = varToConflictSet (P qpn) - -- compose the transformation functions for each of the relevant constraint - g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id - (M.findWithDefault [] pn pcs) - in PChoiceF qpn gr (P.mapWithKey g ts) - go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = - let c = varToConflictSet (F qfn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id - (M.findWithDefault [] pn pcs) - in FChoiceF qfn gr tr m (P.mapWithKey g ts) - go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = - let c = varToConflictSet (S qsn) - -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id - (M.findWithDefault [] pn pcs) - in SChoiceF qsn gr tr (P.mapWithKey g ts) - go x = x - --- | Transformation that tries to enforce manual flags. Manual flags --- can only be re-set explicitly by the user. This transformation should --- be run after user preferences have been enforced. For manual flags, --- it checks if a user choice has been made. If not, it disables all but --- the first choice. -enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason -enforceManualFlags = trav go - where - go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $ - let c = varToConflictSet (F qfn) - in case span isDisabled (P.toList ts) of - ([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys) - _ -> ts -- something has been manually selected, leave things alone - where - isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True - isDisabled _ = False - go x = x - --- | Require installed packages. -requireInstalled :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason -requireInstalled p = trav go - where - go (PChoiceF v@(Q _ pn) gr cs) - | p pn = PChoiceF v gr (P.mapWithKey installed cs) - | otherwise = PChoiceF v gr cs - where - installed (POption (I _ (Inst _)) _) x = x - installed _ _ = Fail (varToConflictSet (P v)) CannotInstall - go x = x - --- | Avoid reinstalls. --- --- This is a tricky strategy. If a package version is installed already and the --- same version is available from a repo, the repo version will never be chosen. --- This would result in a reinstall (either destructively, or potentially, --- shadowing). The old instance won't be visible or even present anymore, but --- other packages might have depended on it. --- --- TODO: It would be better to actually check the reverse dependencies of installed --- packages. If they're not depended on, then reinstalling should be fine. Even if --- they are, perhaps this should just result in trying to reinstall those other --- packages as well. However, doing this all neatly in one pass would require to --- change the builder, or at least to change the goal set after building. -avoidReinstalls :: (PN -> Bool) -> Tree QGoalReason -> Tree QGoalReason -avoidReinstalls p = trav go - where - go (PChoiceF qpn@(Q _ pn) gr cs) - | p pn = PChoiceF qpn gr disableReinstalls - | otherwise = PChoiceF qpn gr cs - where - disableReinstalls = - let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ] - in P.mapWithKey (notReinstall installed) cs - - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = - Fail (varToConflictSet (P qpn)) CannotReinstall - notReinstall _ _ x = - x - go x = x - --- | Always choose the first goal in the list next, abandoning all --- other choices. --- --- This is unnecessary for the default search strategy, because --- it descends only into the first goal choice anyway, --- but may still make sense to just reduce the tree size a bit. -firstGoal :: Tree a -> Tree a -firstGoal = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs) - go x = x - -- Note that we keep empty choice nodes, because they mean success. - --- | Transformation that tries to make a decision on base as early as --- possible. In nearly all cases, there's a single choice for the base --- package. Also, fixing base early should lead to better error messages. -preferBaseGoalChoice :: Tree a -> Tree a -preferBaseGoalChoice = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs) - go x = x - - isBase :: OpenGoal comp -> Bool - isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True - isBase _ = False - --- | Deal with setup dependencies after regular dependencies, so that we can --- will link setup depencencies against package dependencies when possible -deferSetupChoices :: Tree a -> Tree a -deferSetupChoices = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs) - go x = x - - noSetup :: OpenGoal comp -> Bool - noSetup (OpenGoal (Simple (Dep (Q (PP _ns (Setup _)) _) _) _) _) = False - noSetup _ = True - --- | Transformation that tries to avoid making weak flag choices early. --- Weak flags are trivial flags (not influencing dependencies) or such --- flags that are explicitly declared to be weak in the index. -deferWeakFlagChoices :: Tree a -> Tree a -deferWeakFlagChoices = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs)) - go x = x - - noWeakStanza :: Tree a -> Bool - noWeakStanza (SChoice _ _ True _) = False - noWeakStanza _ = True - - noWeakFlag :: Tree a -> Bool - noWeakFlag (FChoice _ _ True _ _) = False - noWeakFlag _ = True - --- | Transformation that sorts choice nodes so that --- child nodes with a small branching degree are preferred. --- --- Only approximates the number of choices in the branches. --- In particular, we try to take any goal immediately if it has --- a branching degree of 0 (guaranteed failure) or 1 (no other --- choice possible). --- --- Returns at most one choice. --- -preferEasyGoalChoices :: Tree a -> Tree a -preferEasyGoalChoices = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs) - -- (a different implementation that seems slower): - -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs)) - go x = x - --- | A variant of 'preferEasyGoalChoices' that just keeps the --- ones with a branching degree of 0 or 1. Note that unlike --- 'preferEasyGoalChoices', this may return more than one --- choice. --- -preferReallyEasyGoalChoices :: Tree a -> Tree a -preferReallyEasyGoalChoices = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs) - go x = x - --- | Monad used internally in enforceSingleInstanceRestriction --- --- For each package instance we record the goal for which we picked a concrete --- instance. The SIR means that for any package instance there can only be one. -type EnforceSIR = Reader (Map (PI PN) QPN) - --- | Enforce ghc's single instance restriction --- --- From the solver's perspective, this means that for any package instance --- (that is, package name + package version) there can be at most one qualified --- goal resolving to that instance (there may be other goals _linking_ to that --- instance however). -enforceSingleInstanceRestriction :: Tree QGoalReason -> Tree QGoalReason -enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go - where - go :: TreeF QGoalReason (EnforceSIR (Tree QGoalReason)) -> EnforceSIR (Tree QGoalReason) - - -- We just verify package choices. - go (PChoiceF qpn gr cs) = - PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs) - go _otherwise = - innM _otherwise - - -- The check proper - goP :: QPN -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason) - goP qpn@(Q _ pn) (POption i linkedTo) r = do - let inst = PI pn i - env <- ask - case (linkedTo, M.lookup inst env) of - (Just _, _) -> - -- For linked nodes we don't check anything - r - (Nothing, Nothing) -> - -- Not linked, not already used - local (M.insert inst qpn) r - (Nothing, Just qpn') -> do - -- Not linked, already used. This is an error - return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Solver.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Distribution.Client.Dependency.Modular.Solver - ( SolverConfig(..) - , solve - ) where - -import Data.Map as M - -import Distribution.Compiler (CompilerInfo) - -import Distribution.Client.PkgConfigDb (PkgConfigDb) - -import Distribution.Client.Dependency.Types - -import Distribution.Client.Dependency.Modular.Assignment -import Distribution.Client.Dependency.Modular.Builder -import Distribution.Client.Dependency.Modular.Cycles -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Explore -import Distribution.Client.Dependency.Modular.Index -import Distribution.Client.Dependency.Modular.Log -import Distribution.Client.Dependency.Modular.Message -import Distribution.Client.Dependency.Modular.Package -import qualified Distribution.Client.Dependency.Modular.Preference as P -import Distribution.Client.Dependency.Modular.Validate -import Distribution.Client.Dependency.Modular.Linking - --- | Various options for the modular solver. -data SolverConfig = SolverConfig { - preferEasyGoalChoices :: Bool, - independentGoals :: Bool, - avoidReinstalls :: Bool, - shadowPkgs :: Bool, - strongFlags :: Bool, - maxBackjumps :: Maybe Int -} - --- | Run all solver phases. --- --- In principle, we have a valid tree after 'validationPhase', which --- means that every 'Done' node should correspond to valid solution. --- --- There is one exception, though, and that is cycle detection, which --- has been added relatively recently. Cycles are only removed directly --- before exploration. --- --- Semantically, there is no difference. Cycle detection, as implemented --- now, only occurs for 'Done' nodes we encounter during exploration, --- and cycle detection itself does not change the shape of the tree, --- it only marks some 'Done' nodes as 'Fail', if they contain cyclic --- solutions. --- --- There is a tiny performance impact, however, in doing cycle detection --- directly after validation. Probably because cycle detection maintains --- some information, and the various reorderings implemented by --- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more --- costly if that information is already around during the reorderings. --- --- With the current positioning directly before the 'explorePhase', there --- seems to be no statistically significant performance impact of cycle --- detection in the common case where there are no cycles. --- -solve :: SolverConfig -> -- ^ solver parameters - CompilerInfo -> - Index -> -- ^ all available packages as an index - PkgConfigDb -> -- ^ available pkg-config pkgs - (PN -> PackagePreferences) -> -- ^ preferences - Map PN [LabeledPackageConstraint] -> -- ^ global constraints - [PN] -> -- ^ global goals - Log Message (Assignment, RevDepMap) -solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = - explorePhase $ - detectCyclesPhase$ - heuristicsPhase $ - preferencesPhase $ - validationPhase $ - prunePhase $ - buildPhase - where - explorePhase = backjumpAndExplore - heuristicsPhase = (if preferEasyGoalChoices sc - then P.preferEasyGoalChoices -- also leaves just one choice - else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space) - P.deferWeakFlagChoices . - P.deferSetupChoices . - P.preferBaseGoalChoice . - P.preferLinked - preferencesPhase = P.preferPackagePreferences userPrefs - validationPhase = P.enforceManualFlags . -- can only be done after user constraints - P.enforcePackageConstraints userConstraints . - P.enforceSingleInstanceRestriction . - validateLinking idx . - validateTree cinfo idx pkgConfigDB - prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . - -- packages that can never be "upgraded": - P.requireInstalled (`elem` [ PackageName "base" - , PackageName "ghc-prim" - , PackageName "integer-gmp" - , PackageName "integer-simple" - ]) - buildPhase = addLinking $ buildTree idx (independentGoals sc) userGoals diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Tree.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -module Distribution.Client.Dependency.Modular.Tree - ( FailReason(..) - , POption(..) - , Tree(..) - , TreeF(..) - , ana - , cata - , choices - , dchoices - , inn - , innM - , para - , trav - , zeroOrOneChoices - ) where - -import Control.Monad hiding (mapM, sequence) -import Data.Foldable -import Data.Traversable -import Prelude hiding (foldr, mapM, sequence) - -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package -import Distribution.Client.Dependency.Modular.PSQ (PSQ) -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import Distribution.Client.Dependency.Modular.Version -import Distribution.Client.Dependency.Types ( ConstraintSource(..) ) - --- | Type of the search tree. Inlining the choice nodes for now. -data Tree a = - PChoice QPN a (PSQ POption (Tree a)) - | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual - | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial - | GoalChoice (PSQ (OpenGoal ()) (Tree a)) -- PSQ should never be empty - | Done RevDepMap - | Fail (ConflictSet QPN) FailReason - deriving (Eq, Show, Functor) - -- Above, a choice is called trivial if it clearly does not matter. The - -- special case of triviality we actually consider is if there are no new - -- dependencies introduced by this node. - -- - -- A (flag) choice is called weak if we do want to defer it. This is the - -- case for flags that should be implied by what's currently installed on - -- the system, as opposed to flags that are used to explicitly enable or - -- disable some functionality. - --- | A package option is a package instance with an optional linking annotation --- --- The modular solver has a number of package goals to solve for, and can only --- pick a single package version for a single goal. In order to allow to --- install multiple versions of the same package as part of a single solution --- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both --- be qualified goals for @P@, allowing to pick a difference version of package --- @P@ for @0.P@ and @1.P@. --- --- Linking is an essential part of this story. In addition to picking a specific --- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or --- vice versa). Teans that @1.P@ and @0.P@ really must be the very same package --- (and hence must have the same build time configuration, and their --- dependencies must also be the exact same). --- --- See for details. -data POption = POption I (Maybe PP) - deriving (Eq, Show) - -data FailReason = InconsistentInitialConstraints - | Conflicting [Dep QPN] - | CannotInstall - | CannotReinstall - | Shadowed - | Broken - | GlobalConstraintVersion VR ConstraintSource - | GlobalConstraintInstalled ConstraintSource - | GlobalConstraintSource ConstraintSource - | GlobalConstraintFlag ConstraintSource - | ManualFlag - | MalformedFlagChoice QFN - | MalformedStanzaChoice QSN - | EmptyGoalChoice - | Backjump - | MultipleInstances - | DependenciesNotLinked String - | CyclicDependencies - deriving (Eq, Show) - --- | Functor for the tree type. -data TreeF a b = - PChoiceF QPN a (PSQ POption b) - | FChoiceF QFN a Bool Bool (PSQ Bool b) - | SChoiceF QSN a Bool (PSQ Bool b) - | GoalChoiceF (PSQ (OpenGoal ()) b) - | DoneF RevDepMap - | FailF (ConflictSet QPN) FailReason - deriving (Functor, Foldable, Traversable) - -out :: Tree a -> TreeF a (Tree a) -out (PChoice p i ts) = PChoiceF p i ts -out (FChoice p i b m ts) = FChoiceF p i b m ts -out (SChoice p i b ts) = SChoiceF p i b ts -out (GoalChoice ts) = GoalChoiceF ts -out (Done x ) = DoneF x -out (Fail c x ) = FailF c x - -inn :: TreeF a (Tree a) -> Tree a -inn (PChoiceF p i ts) = PChoice p i ts -inn (FChoiceF p i b m ts) = FChoice p i b m ts -inn (SChoiceF p i b ts) = SChoice p i b ts -inn (GoalChoiceF ts) = GoalChoice ts -inn (DoneF x ) = Done x -inn (FailF c x ) = Fail c x - -innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a) -innM (PChoiceF p i ts) = liftM (PChoice p i ) (sequence ts) -innM (FChoiceF p i b m ts) = liftM (FChoice p i b m) (sequence ts) -innM (SChoiceF p i b ts) = liftM (SChoice p i b ) (sequence ts) -innM (GoalChoiceF ts) = liftM (GoalChoice ) (sequence ts) -innM (DoneF x ) = return $ Done x -innM (FailF c x ) = return $ Fail c x - --- | Determines whether a tree is active, i.e., isn't a failure node. -active :: Tree a -> Bool -active (Fail _ _) = False -active _ = True - --- | Determines how many active choices are available in a node. Note that we --- count goal choices as having one choice, always. -choices :: Tree a -> Int -choices (PChoice _ _ ts) = P.length (P.filter active ts) -choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts) -choices (SChoice _ _ _ ts) = P.length (P.filter active ts) -choices (GoalChoice _ ) = 1 -choices (Done _ ) = 1 -choices (Fail _ _ ) = 0 - --- | Variant of 'choices' that only approximates the number of choices. -dchoices :: Tree a -> P.Degree -dchoices (PChoice _ _ ts) = P.degree (P.filter active ts) -dchoices (FChoice _ _ _ _ ts) = P.degree (P.filter active ts) -dchoices (SChoice _ _ _ ts) = P.degree (P.filter active ts) -dchoices (GoalChoice _ ) = P.ZeroOrOne -dchoices (Done _ ) = P.ZeroOrOne -dchoices (Fail _ _ ) = P.ZeroOrOne - --- | Variant of 'choices' that only approximates the number of choices. -zeroOrOneChoices :: Tree a -> Bool -zeroOrOneChoices (PChoice _ _ ts) = P.isZeroOrOne (P.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts) -zeroOrOneChoices (SChoice _ _ _ ts) = P.isZeroOrOne (P.filter active ts) -zeroOrOneChoices (GoalChoice _ ) = True -zeroOrOneChoices (Done _ ) = True -zeroOrOneChoices (Fail _ _ ) = True - --- | Catamorphism on trees. -cata :: (TreeF a b -> b) -> Tree a -> b -cata phi x = (phi . fmap (cata phi) . out) x - -trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b -trav psi x = cata (inn . psi) x - --- | Paramorphism on trees. -para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b -para phi = phi . fmap (\ x -> (para phi x, x)) . out - --- | Anamorphism on trees. -ana :: (b -> TreeF a b) -> b -> Tree a -ana psi = inn . fmap (ana psi) . psi diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Validate.hs +++ /dev/null @@ -1,269 +0,0 @@ -module Distribution.Client.Dependency.Modular.Validate (validateTree) where - --- Validation of the tree. --- --- The task here is to make sure all constraints hold. After validation, any --- assignment returned by exploration of the tree should be a complete valid --- assignment, i.e., actually constitute a solution. - -import Control.Applicative -import Control.Monad.Reader hiding (sequence) -import Data.List as L -import Data.Map as M -import Data.Set as S -import Data.Traversable -import Prelude hiding (sequence) - -import Language.Haskell.Extension (Extension, Language) - -import Distribution.Compiler (CompilerInfo(..)) - -import Distribution.Client.Dependency.Modular.Assignment -import Distribution.Client.Dependency.Modular.Dependency -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Index -import Distribution.Client.Dependency.Modular.Package -import qualified Distribution.Client.Dependency.Modular.PSQ as P -import Distribution.Client.Dependency.Modular.Tree -import Distribution.Client.Dependency.Modular.Version (VR) - -import Distribution.Client.ComponentDeps (Component) -import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) - --- In practice, most constraints are implication constraints (IF we have made --- a number of choices, THEN we also have to ensure that). We call constraints --- that for which the preconditions are fulfilled ACTIVE. We maintain a set --- of currently active constraints that we pass down the node. --- --- We aim at detecting inconsistent states as early as possible. --- --- Whenever we make a choice, there are two things that need to happen: --- --- (1) We must check that the choice is consistent with the currently --- active constraints. --- --- (2) The choice increases the set of active constraints. For the new --- active constraints, we must check that they are consistent with --- the current state. --- --- We can actually merge (1) and (2) by saying the the current choice is --- a new active constraint, fixing the choice. --- --- If a test fails, we have detected an inconsistent state. We can --- disable the current subtree and do not have to traverse it any further. --- --- We need a good way to represent the current state, i.e., the current --- set of active constraints. Since the main situation where we have to --- search in it is (1), it seems best to store the state by package: for --- every package, we store which versions are still allowed. If for any --- package, we have inconsistent active constraints, we can also stop. --- This is a particular way to read task (2): --- --- (2, weak) We only check if the new constraints are consistent with --- the choices we've already made, and add them to the active set. --- --- (2, strong) We check if the new constraints are consistent with the --- choices we've already made, and the constraints we already have. --- --- It currently seems as if we're implementing the weak variant. However, --- when used together with 'preferEasyGoalChoices', we will find an --- inconsistent state in the very next step. --- --- What do we do about flags? --- --- Like for packages, we store the flag choices we have already made. --- Now, regarding (1), we only have to test whether we've decided the --- current flag before. Regarding (2), the interesting bit is in discovering --- the new active constraints. To this end, we look up the constraints for --- the package the flag belongs to, and traverse its flagged dependencies. --- Wherever we find the flag in question, we start recording dependencies --- underneath as new active dependencies. If we encounter other flags, we --- check if we've chosen them already and either proceed or stop. - --- | The state needed during validation. -data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: PN -> VR -> Bool, - index :: Index, - saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies - pa :: PreAssignment, - qualifyOptions :: QualifyOptions -} - -type Validate = Reader ValidateState - -validate :: Tree QGoalReason -> Validate (Tree QGoalReason) -validate = cata go - where - go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason) - - go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) ts) - go (FChoiceF qfn gr b m ts) = - do - -- Flag choices may occur repeatedly (because they can introduce new constraints - -- in various places). However, subsequent choices must be consistent. We thereby - -- collapse repeated flag choice nodes. - PA _ pfa _ <- asks pa -- obtain current flag-preassignment - case M.lookup qfn pfa of - Just rb -> -- flag has already been assigned; collapse choice to the correct branch - case P.lookup rb ts of - Just t -> goF qfn rb t - Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) - Nothing -> -- flag choice is new, follow both branches - FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn) ts) - go (SChoiceF qsn gr b ts) = - do - -- Optional stanza choices are very similar to flag choices. - PA _ _ psa <- asks pa -- obtain current stanza-preassignment - case M.lookup qsn psa of - Just rb -> -- stanza choice has already been made; collapse choice to the correct branch - case P.lookup rb ts of - Just t -> goS qsn rb t - Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) - Nothing -> -- stanza choice is new, follow both branches - SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn) ts) - - -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF ts) = GoalChoice <$> sequence ts - go (DoneF rdm ) = pure (Done rdm) - go (FailF c fr ) = pure (Fail c fr) - - -- What to do for package nodes ... - goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goP qpn@(Q _pp pn) (POption i _) r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - idx <- asks index -- obtain the index - svd <- asks saved -- obtain saved dependencies - qo <- asks qualifyOptions - -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps _ mfr) = idx ! pn ! i - -- qualify the deps in the current scope - let qdeps = qualifyDeps qo qpn deps - -- the new active constraints are given by the instance we have chosen, - -- plus the dependency information we have for that instance - let newactives = Dep qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) - -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives - -- In case we continue, we save the scoped dependencies - let nsvd = M.insert qpn qdeps svd - case mfr of - Just fr -> -- The index marks this as an invalid choice. We can stop. - return (Fail (varToConflictSet (P qpn)) fr) - _ -> case mnppa of - Left (c, d) -> -- We have an inconsistency. We can stop. - return (Fail c (Conflicting d)) - Right nppa -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r - - -- What to do for flag nodes ... - goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goF qfn@(FN (PI qpn _i) _f) b r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npfa = M.insert qfn b pfa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (F qfn) b npfa psa qdeps - -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r - - -- What to do for stanza nodes (similar to flag nodes) ... - goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason) - goS qsn@(SN (PI qpn _i) _f) b r = do - PA ppa pfa psa <- asks pa -- obtain current preassignment - extSupported <- asks supportedExt -- obtain the supported extensions - langSupported <- asks supportedLang -- obtain the supported languages - pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies - -- Note that there should be saved dependencies for the package in question, - -- because while building, we do not choose flags before we see the packages - -- that define them. - let qdeps = svd ! qpn - -- We take the *saved* dependencies, because these have been qualified in the - -- correct scope. - -- - -- Extend the flag assignment - let npsa = M.insert qsn b psa - -- We now try to get the new active dependencies we might learn about because - -- we have chosen a new flag. - let newactives = extractNewDeps (S qsn) b pfa npsa qdeps - -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r - --- | We try to extract as many concrete dependencies from the given flagged --- dependencies as possible. We make use of all the flag knowledge we have --- already acquired. -extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] -extractDeps fa sa deps = do - d <- deps - case d of - Simple sd _ -> return sd - Flagged qfn _ td fd -> case M.lookup qfn fa of - Nothing -> mzero - Just True -> extractDeps fa sa td - Just False -> extractDeps fa sa fd - Stanza qsn td -> case M.lookup qsn sa of - Nothing -> mzero - Just True -> extractDeps fa sa td - Just False -> [] - --- | We try to find new dependencies that become available due to the given --- flag or stanza choice. We therefore look for the choice in question, and then call --- 'extractDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] -extractNewDeps v b fa sa = go - where - go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion) - go deps = do - d <- deps - case d of - Simple _ _ -> mzero - Flagged qfn' _ td fd - | v == F qfn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else extractDeps fa sa fd - | otherwise -> case M.lookup qfn' fa of - Nothing -> mzero - Just True -> go td - Just False -> go fd - Stanza qsn' td - | v == S qsn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else [] - | otherwise -> case M.lookup qsn' sa of - Nothing -> mzero - Just True -> go td - Just False -> [] - --- | Interface. -validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree QGoalReason -> Tree QGoalReason -validateTree cinfo idx pkgConfigDb t = runReader (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in \ x -> S.member x s) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb - , index = idx - , saved = M.empty - , pa = PA M.empty M.empty M.empty - , qualifyOptions = defaultQualifyOptions idx - } diff --git a/Distribution/Client/Dependency/Modular/Var.hs b/Distribution/Client/Dependency/Modular/Var.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Var.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Distribution.Client.Dependency.Modular.Var ( - Var(..) - , simplifyVar - , showVar - , varPI - ) where - -import Prelude hiding (pi) - -import Distribution.Client.Dependency.Modular.Flag -import Distribution.Client.Dependency.Modular.Package - -{------------------------------------------------------------------------------- - Variables --------------------------------------------------------------------------------} - --- | The type of variables that play a role in the solver. --- Note that the tree currently does not use this type directly, --- and rather has separate tree nodes for the different types of --- variables. This fits better with the fact that in most cases, --- these have to be treated differently. -data Var qpn = P qpn | F (FN qpn) | S (SN qpn) - deriving (Eq, Ord, Show, Functor) - --- | For computing conflict sets, we map flag choice vars to a --- single flag choice. This means that all flag choices are treated --- as interdependent. So if one flag of a package ends up in a --- conflict set, then all flags are being treated as being part of --- the conflict set. -simplifyVar :: Var qpn -> Var qpn -simplifyVar (P qpn) = P qpn -simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag")) -simplifyVar (S qsn) = S qsn - -showVar :: Var QPN -> String -showVar (P qpn) = showQPN qpn -showVar (F qfn) = showQFN qfn -showVar (S qsn) = showQSN qsn - --- | Extract the package instance from a Var -varPI :: Var QPN -> (QPN, Maybe I) -varPI (P qpn) = (qpn, Nothing) -varPI (F (FN (PI qpn i) _)) = (qpn, Just i) -varPI (S (SN (PI qpn i) _)) = (qpn, Just i) diff --git a/Distribution/Client/Dependency/Modular/Version.hs b/Distribution/Client/Dependency/Modular/Version.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Modular/Version.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Distribution.Client.Dependency.Modular.Version - ( Ver - , VR - , anyVR - , checkVR - , eqVR - , showVer - , showVR - , simplifyVR - , (.&&.) - , (.||.) - ) where - -import qualified Distribution.Version as CV -- from Cabal -import Distribution.Text -- from Cabal - --- | Preliminary type for versions. -type Ver = CV.Version - --- | String representation of a version. -showVer :: Ver -> String -showVer = display - --- | Version range. Consists of a lower and upper bound. -type VR = CV.VersionRange - --- | String representation of a version range. -showVR :: VR -> String -showVR = display - --- | Unconstrained version range. -anyVR :: VR -anyVR = CV.anyVersion - --- | Version range fixing a single version. -eqVR :: Ver -> VR -eqVR = CV.thisVersion - --- | Intersect two version ranges. -(.&&.) :: VR -> VR -> VR -(.&&.) = CV.intersectVersionRanges - --- | Union of two version ranges. -(.||.) :: VR -> VR -> VR -(.||.) = CV.unionVersionRanges - --- | Simplify a version range. -simplifyVR :: VR -> VR -simplifyVR = CV.simplifyVersionRange - --- | Checking a version against a version range. -checkVR :: VR -> Ver -> Bool -checkVR = flip CV.withinRange diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/TopDown.hs +++ /dev/null @@ -1,1079 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.TopDown ( - topDownResolver - ) where - -import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints -import Distribution.Client.Dependency.TopDown.Constraints - ( Satisfiable(..) ) -import Distribution.Client.Types - ( SourcePackage(..), ConfiguredPackage(..) - , enableStanzas, ConfiguredId(..), fakeUnitId ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, ResolverPackage(..) - , PackageConstraint(..), unlabelPackageConstraint - , PackagePreferences(..), InstalledPreference(..) - , Progress(..), foldProgress ) - -import qualified Distribution.Client.PackageIndex as PackageIndex -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Client.ComponentDeps - ( ComponentDeps ) -import qualified Distribution.Client.ComponentDeps as CD -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Package - ( PackageName(..), PackageId, PackageIdentifier(..) - , UnitId(..), ComponentId(..) - , Package(..), packageVersion, packageName - , Dependency(Dependency), thisPackageVersion, simplifyDependency ) -import Distribution.PackageDescription - ( PackageDescription(buildDepends) ) -import Distribution.Client.PackageUtils - ( externalBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, flattenPackageDescription ) -import Distribution.Version - ( Version(..), VersionRange, withinRange, simplifyVersionRange - , UpperBound(..), asVersionIntervals ) -import Distribution.Compiler - ( CompilerInfo ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils - ( equating, comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy ) -import Data.Maybe - ( fromJust, fromMaybe, catMaybes ) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( Monoid(mempty) ) -#endif -import Control.Monad - ( guard ) -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Control.Exception - ( assert ) - --- ------------------------------------------------------------ --- * Search state types --- ------------------------------------------------------------ - -type Constraints = Constraints.Constraints - InstalledPackageEx UnconfiguredPackage ExclusionReason -type SelectedPackages = PackageIndex SelectedPackage - --- ------------------------------------------------------------ --- * The search tree type --- ------------------------------------------------------------ - -data SearchSpace inherited pkg - = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] - | Failure Failure - --- ------------------------------------------------------------ --- * Traverse a search tree --- ------------------------------------------------------------ - -explore :: (PackageName -> PackagePreferences) - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage - -> Progress Log Failure (SelectedPackages, Constraints) - -explore _ (Failure failure) = Fail failure -explore _ (ChoiceNode (s,c,_) []) = Done (s,c) -explore pref (ChoiceNode _ choices) = - case [ choice | [choice] <- choices ] of - ((_, node'):_) -> Step (logInfo node') (explore pref node') - [] -> Step (logInfo node') (explore pref node') - where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (_, node') = maximumBy (bestByPref pkgname) choice - where - topSortNumber choice = case fst (head choice) of - InstalledOnly (InstalledPackageEx _ i _) -> i - SourceOnly (UnconfiguredPackage _ i _ _) -> i - InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i - - bestByPref pkgname = case packageInstalledPreference of - PreferLatest -> - comparing (\(p,_) -> ( isPreferred p, packageId p)) - PreferInstalled -> - comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) - where - isInstalled (SourceOnly _) = False - isInstalled _ = True - isPreferred p = length . filter (packageVersion p `withinRange`) $ - preferredVersions - - (PackagePreferences preferredVersions packageInstalledPreference _) - = pref pkgname - - logInfo node = Select selected discarded - where (selected, discarded) = case node of - Failure _ -> ([], []) - ChoiceNode (_,_,changes) _ -> changes - --- ------------------------------------------------------------ --- * Generate a search tree --- ------------------------------------------------------------ - -type ConfigurePackage = PackageIndex SelectablePackage - -> SelectablePackage - -> Either [Dependency] SelectedPackage - --- | (packages selected, packages discarded) -type SelectionChanges = ([SelectedPackage], [PackageId]) - -searchSpace :: ConfigurePackage - -> Constraints - -> SelectedPackages - -> SelectionChanges - -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage -searchSpace configure constraints selected changes next = - assert (Set.null (selectedSet `Set.intersection` next)) $ - assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $ - assert (next `Set.isSubsetOf` Constraints.packages constraints) $ - - ChoiceNode (selected, constraints, changes) - [ [ (pkg, select name pkg) - | pkg <- PackageIndex.lookupPackageName available name ] - | name <- Set.elems next ] - where - available = Constraints.choices constraints - - selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected)) - - select name pkg = case configure available pkg of - Left missing -> Failure $ ConfigureFailed pkg - [ (dep, Constraints.conflicting constraints dep) - | dep <- missing ] - Right pkg' -> - case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of - Left failure -> Failure failure - Right (constraints', newDiscarded) -> - searchSpace configure - constraints' selected' (newSelected, newDiscarded) next' - where - selected' = foldl' (flip PackageIndex.insert) selected newSelected - newSelected = - case Constraints.isPaired constraints (packageId pkg) of - Nothing -> [pkg'] - Just pkgid' -> [pkg', pkg''] - where - Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) - (PackageIndex.lookupPackageId available pkgid') - - newPkgs = [ name' - | (Dependency name' _, _) <- newDeps - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = concatMap packageConstraints newSelected - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - -packageConstraints :: SelectedPackage -> [(Dependency, Bool)] -packageConstraints = either installedConstraints availableConstraints - . preferSource - where - preferSource (InstalledOnly pkg) = Left pkg - preferSource (SourceOnly pkg) = Right pkg - preferSource (InstalledAndSource _ pkg) = Right pkg - installedConstraints (InstalledPackageEx _ _ deps) = - [ (thisPackageVersion dep, True) - | dep <- deps ] - availableConstraints (SemiConfiguredPackage _ _ _ deps) = - [ (dep, False) | dep <- deps ] - -addDeps :: Constraints -> [PackageName] -> Constraints -addDeps = - foldr $ \pkgname cs -> - case Constraints.addTarget pkgname cs of - Satisfiable cs' () -> cs' - _ -> impossible "addDeps unsatisfiable" - -constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints - -> [PackageId] - -> Either Failure (Constraints, [PackageId]) -constrainDeps pkg [] cs discard = - case addPackageSelectConstraint (packageId pkg) cs of - Satisfiable cs' discard' -> Right (cs', discard' ++ discard) - _ -> impossible "constrainDeps unsatisfiable(1)" -constrainDeps pkg ((dep, installedConstraint):deps) cs discard = - case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of - Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) - Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)" - ConflictsWith conflicts -> - Left (DependencyConflict pkg dep installedConstraint conflicts) - --- ------------------------------------------------------------ --- * The main algorithm --- ------------------------------------------------------------ - -search :: ConfigurePackage - -> (PackageName -> PackagePreferences) - -> Constraints - -> Set PackageName - -> Progress Log Failure (SelectedPackages, Constraints) -search configure pref constraints = - explore pref . searchSpace configure constraints mempty ([], []) - --- ------------------------------------------------------------ --- * The top level resolver --- ------------------------------------------------------------ - --- | The main exported resolver, with string logging and failure types to fit --- the standard 'DependencyResolver' interface. --- -topDownResolver :: DependencyResolver -topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB - preferences constraints targets = - mapMessages $ topDownResolver' - platform cinfo - (convertInstalledPackageIndex installedPkgIndex) - sourcePkgIndex - preferences - (map unlabelPackageConstraint constraints) - targets - where - mapMessages :: Progress Log Failure a -> Progress String String a - mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done - --- | The native resolver with detailed structured logging and failure types. --- -topDownResolver' :: Platform -> CompilerInfo - -> PackageIndex InstalledPackage - -> PackageIndex SourcePackage - -> (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> Progress Log Failure [ResolverPackage] -topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex - preferences constraints targets = - fmap (uncurry finalise) - . (\cs -> search configure preferences cs initialPkgNames) - =<< pruneBottomUp platform cinfo - =<< addTopLevelConstraints constraints - =<< addTopLevelTargets targets emptyConstraintSet - - where - configure = configurePackage platform cinfo - emptyConstraintSet :: Constraints - emptyConstraintSet = Constraints.empty - (annotateInstalledPackages topSortNumber installedPkgIndex') - (annotateSourcePackages constraints topSortNumber sourcePkgIndex') - (installedPkgIndex', sourcePkgIndex') = - selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames - topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex' - - initialPkgNames = Set.fromList targets - - finalise selected' constraints' = - map toResolverPackage - . PackageIndex.allPackages - . fst . improvePlan installedPkgIndex' constraints' - . PackageIndex.fromList - $ finaliseSelectedPackages preferences selected' constraints' - - toResolverPackage :: FinalSelectedPackage -> ResolverPackage - toResolverPackage (SelectedInstalled (InstalledPackage pkg _)) - = PreExisting pkg - toResolverPackage (SelectedSource pkg) = Configured pkg - -addTopLevelTargets :: [PackageName] - -> Constraints - -> Progress a Failure Constraints -addTopLevelTargets [] cs = Done cs -addTopLevelTargets (pkg:pkgs) cs = - case Constraints.addTarget pkg cs of - Satisfiable cs' () -> addTopLevelTargets pkgs cs' - Unsatisfiable -> Fail (NoSuchPackage pkg) - ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts" - - -addTopLevelConstraints :: [PackageConstraint] -> Constraints - -> Progress Log Failure Constraints -addTopLevelConstraints [] cs = Done cs -addTopLevelConstraints (PackageConstraintFlags _ _ :deps) cs = - addTopLevelConstraints deps cs - -addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs = - case addTopLevelVersionConstraint pkg ver cs of - Satisfiable cs' pkgids -> - Step (AppliedVersionConstraint pkg ver pkgids) - (addTopLevelConstraints deps cs') - - Unsatisfiable -> - Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) - - ConflictsWith conflicts -> - Fail (TopLevelVersionConstraintConflict pkg ver conflicts) - -addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs = - case addTopLevelInstalledConstraint pkg cs of - Satisfiable cs' pkgids -> - Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids) - (addTopLevelConstraints deps cs') - - Unsatisfiable -> - Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint) - - ConflictsWith conflicts -> - Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts) - -addTopLevelConstraints (PackageConstraintSource pkg:deps) cs = - case addTopLevelSourceConstraint pkg cs of - Satisfiable cs' pkgids -> - Step (AppliedInstalledConstraint pkg SourceConstraint pkgids) - (addTopLevelConstraints deps cs') - - Unsatisfiable -> - Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint) - - ConflictsWith conflicts -> - Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts) - -addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs = - addTopLevelConstraints deps cs - --- | Add exclusion on available packages that cannot be configured. --- -pruneBottomUp :: Platform -> CompilerInfo - -> Constraints -> Progress Log Failure Constraints -pruneBottomUp platform comp constraints = - foldr prune Done (initialPackages constraints) constraints - - where - prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs - where - unconfigurable = - [ (pkg, missing) -- if necessary we could look up missing reasons - | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs - , Left missing <- [configure cs pkg'] ] - - addExcludeConstraint (pkg, missing) rest cs = - let reason = ExcludedByConfigureFail missing in - case addPackageExcludeConstraint (packageId pkg) reason cs of - Satisfiable cs' [pkgid]| packageId pkg == pkgid - -> Step (ExcludeUnconfigurable pkgid) (rest cs') - Satisfiable _ _ -> impossible "pruneBottomUp satisfiable" - _ -> Fail $ ConfigureFailed pkg - [ (dep, Constraints.conflicting cs dep) - | dep <- missing ] - - configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) = - finalizePackageDescription flags (dependencySatisfiable cs) - platform comp [] (enableStanzas stanzas pkg) - dependencySatisfiable cs = - not . null . PackageIndex.lookupDependency (Constraints.choices cs) - - -- collect each group of packages (by name) in reverse topsort order - initialPackages = - reverse - . sortBy (comparing (topSortNumber . head)) - . PackageIndex.allPackagesByName - . Constraints.choices - - topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i - topSortNumber (SourceOnly (UnconfiguredPackage _ i _ _)) = i - topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i - - getSourcePkg (InstalledOnly _ ) = Nothing - getSourcePkg (SourceOnly spkg) = Just spkg - getSourcePkg (InstalledAndSource _ spkg) = Just spkg - - -configurePackage :: Platform -> CompilerInfo -> ConfigurePackage -configurePackage platform cinfo available spkg = case spkg of - InstalledOnly ipkg -> Right (InstalledOnly ipkg) - SourceOnly apkg -> fmap SourceOnly (configure apkg) - InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) - (configure apkg) - where - configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) = - case finalizePackageDescription flags dependencySatisfiable - platform cinfo [] - (enableStanzas stanzas p) of - Left missing -> Left missing - Right (pkg, flags') -> Right $ - SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg) - - dependencySatisfiable = not . null . PackageIndex.lookupDependency available - --- | Annotate each installed packages with its set of transitive dependencies --- and its topological sort number. --- -annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) - -> PackageIndex InstalledPackage - -> PackageIndex InstalledPackageEx -annotateInstalledPackages dfsNumber installed = PackageIndex.fromList - [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) - | pkg <- PackageIndex.allPackages installed ] - where - transitiveDepends :: InstalledPackage -> [PackageId] - transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph - . fromJust . toVertex . packageId - (graph, toPkg, toVertex) = dependencyGraph installed - - --- | Annotate each available packages with its topological sort number and any --- user-supplied partial flag assignment. --- -annotateSourcePackages :: [PackageConstraint] - -> (PackageName -> TopologicalSortNumber) - -> PackageIndex SourcePackage - -> PackageIndex UnconfiguredPackage -annotateSourcePackages constraints dfsNumber sourcePkgIndex = - PackageIndex.fromList - [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name) - | pkg <- PackageIndex.allPackages sourcePkgIndex - , let name = packageName pkg ] - where - flagsFor = fromMaybe [] . flip Map.lookup flagsMap - flagsMap = Map.fromList - [ (name, flags) - | PackageConstraintFlags name flags <- constraints ] - stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap - stanzasMap = Map.fromListWith (++) - [ (name, stanzas) - | PackageConstraintStanzas name stanzas <- constraints ] - --- | One of the heuristics we use when guessing which path to take in the --- search space is an ordering on the choices we make. It's generally better --- to make decisions about packages higer in the dep graph first since they --- place constraints on packages lower in the dep graph. --- --- To pick them in that order we annotate each package with its topological --- sort number. So if package A depends on package B then package A will have --- a lower topological sort number than B and we'll make a choice about which --- version of A to pick before we make a choice about B (unless there is only --- one possible choice for B in which case we pick that immediately). --- --- To construct these topological sort numbers we combine and flatten the --- installed and source package sets. We consider only dependencies between --- named packages, not including versions and for not-yet-configured packages --- we look at all the possible dependencies, not just those under any single --- flag assignment. This means we can actually get impossible combinations of --- edges and even cycles, but that doesn't really matter here, it's only a --- heuristic. --- -topologicalSortNumbering :: PackageIndex InstalledPackage - -> PackageIndex SourcePackage - -> (PackageName -> TopologicalSortNumber) -topologicalSortNumbering installedPkgIndex sourcePkgIndex = - \pkgname -> let Just vertex = toVertex pkgname - in topologicalSortNumbers Array.! vertex - where - topologicalSortNumbers = Array.array (Array.bounds graph) - (zip (Graph.topSort graph) [0..]) - (graph, _, toVertex) = Graph.graphFromEdges $ - [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex - , let deps = [ packageName dep - | pkg' <- pkgs - , dep <- sourceDeps pkg' ] ] - ++ [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex - , let deps = [ depName - | SourcePackage _ pkg' _ _ <- pkgs - , Dependency depName _ <- - buildDepends (flattenPackageDescription pkg') ] ] - --- | We don't need the entire index (which is rather large and costly if we --- force it by examining the whole thing). So trace out the maximul subset of --- each index that we could possibly ever need. Do this by flattening packages --- and looking at the names of all possible dependencies. --- -selectNeededSubset :: PackageIndex InstalledPackage - -> PackageIndex SourcePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,PackageIndex SourcePackage) -selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty - where - select :: PackageIndex InstalledPackage - -> PackageIndex SourcePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,PackageIndex SourcePackage) - select installedPkgIndex' sourcePkgIndex' remaining - | Set.null remaining = (installedPkgIndex', sourcePkgIndex') - | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining'' - where - (next, remaining') = Set.deleteFindMin remaining - moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next - moreSource = PackageIndex.lookupPackageName sourcePkgIndex next - moreRemaining = -- we filter out packages already included in the indexes - -- this avoids an infinite loop if a package depends on itself - -- like base-3.0.3.0 with base-4.0.0.0 - filter notAlreadyIncluded - $ [ packageName dep - | pkg <- moreInstalled - , dep <- sourceDeps pkg ] - ++ [ name - | SourcePackage _ pkg _ _ <- moreSource - , Dependency name _ <- - buildDepends (flattenPackageDescription pkg) ] - installedPkgIndex'' = foldl' (flip PackageIndex.insert) - installedPkgIndex' moreInstalled - sourcePkgIndex'' = foldl' (flip PackageIndex.insert) - sourcePkgIndex' moreSource - remaining'' = foldl' (flip Set.insert) - remaining' moreRemaining - notAlreadyIncluded name = - null (PackageIndex.lookupPackageName installedPkgIndex' name) - && null (PackageIndex.lookupPackageName sourcePkgIndex' name) - - --- | The old top down solver assumes that installed packages are indexed by --- their source package id. But these days they're actually indexed by an --- installed package id and there can be many installed packages with the same --- source package id. This function tries to do a convertion, but it can only --- be partial. --- -convertInstalledPackageIndex :: InstalledPackageIndex - -> PackageIndex InstalledPackage -convertInstalledPackageIndex index' = PackageIndex.fromList - -- There can be multiple installed instances of each package version, - -- like when the same package is installed in the global & user DBs. - -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the - -- installed packages with the most preferred instances first, so by - -- picking the first we should get the user one. This is almost but not - -- quite the same as what ghc does. - [ InstalledPackage ipkg (sourceDepsOf index' ipkg) - | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ] - where - -- The InstalledPackageInfo only lists dependencies by the - -- UnitId, which means we do not directly know the corresponding - -- source dependency. The only way to find out is to lookup the - -- UnitId to get the InstalledPackageInfo and look at its - -- source PackageId. But if the package is broken because it depends on - -- other packages that do not exist then we have a problem we cannot find - -- the original source package id. Instead we make up a bogus package id. - -- This should have the same effect since it should be a dependency on a - -- nonexistent package. - sourceDepsOf index ipkg = - [ maybe (brokenPackageId depid) packageId mdep - | let depids = InstalledPackageInfo.depends ipkg - getpkg = InstalledPackageIndex.lookupUnitId index - , (depid, mdep) <- zip depids (map getpkg depids) ] - - brokenPackageId (SimpleUnitId (ComponentId str)) = - PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) - --- ------------------------------------------------------------ --- * Post processing the solution --- ------------------------------------------------------------ - -finaliseSelectedPackages :: (PackageName -> PackagePreferences) - -> SelectedPackages - -> Constraints - -> [FinalSelectedPackage] -finaliseSelectedPackages pref selected constraints = - map finaliseSelected (PackageIndex.allPackages selected) - where - remainingChoices = Constraints.choices constraints - finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg - finaliseSelected (SourceOnly apkg) = finaliseSource Nothing apkg - finaliseSelected (InstalledAndSource ipkg apkg) = - case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of - --picked package not in constraints - Nothing -> impossible "finaliseSelected no pkg" - -- to constrain to avail only: - Just (SourceOnly _) -> impossible "finaliseSelected src only" - Just (InstalledOnly _) -> finaliseInstalled ipkg - Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg - - finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg - finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) = - SelectedSource (ConfiguredPackage pkg flags stanzas deps') - where - -- We cheat in the cabal solver, and classify all dependencies as - -- library dependencies. - deps' :: ComponentDeps [ConfiguredId] - deps' = CD.fromLibraryDeps $ map (confId . pickRemaining mipkg) deps - - -- InstalledOrSource indicates that we either have a source package - -- available, or an installed one, or both. In the case that we have both - -- available, we don't yet know if we can pick the installed one (the - -- dependencies may not match up, for instance); this is verified in - -- `improvePlan`. - -- - -- This means that at this point we cannot construct a valid installed - -- package ID yet for the dependencies. We therefore have two options: - -- - -- * We could leave the installed package ID undefined here, and have a - -- separate pass over the output of the top-down solver, fixing all - -- dependencies so that if we depend on an already installed package we - -- use the proper installed package ID. - -- - -- * We can _always_ use fake installed IDs, irrespective of whether we the - -- dependency is on an already installed package or not. This is okay - -- because (i) the top-down solver does not (and never will) support - -- multiple package instances, and (ii) we initialize the FakeMap with - -- fake IDs for already installed packages. - -- - -- For now we use the second option; if however we change the implementation - -- of these fake IDs so that we do away with the FakeMap and update a - -- package reverse dependencies as we execute the install plan and discover - -- real package IDs, then this is no longer possible and we have to - -- implement the first option (see also Note [FakeMap] in Cabal). - confId :: InstalledOrSource InstalledPackageEx UnconfiguredPackage -> ConfiguredId - confId pkg = ConfiguredId { - confSrcId = packageId pkg - , confInstId = fakeUnitId (packageId pkg) - } - - pickRemaining mipkg dep@(Dependency _name versionRange) = - case PackageIndex.lookupDependency remainingChoices dep of - [] -> impossible "pickRemaining no pkg" - [pkg'] -> pkg' - remaining -> assert (checkIsPaired remaining) - $ maximumBy bestByPref remaining - where - -- We order candidate packages to pick for a dependency by these - -- three factors. The last factor is just highest version wins. - bestByPref = - comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) - -- Is the package already used by the installed version of this - -- package? If so we should pick that first. This stops us from doing - -- silly things like deciding to rebuild haskell98 against base 3. - isCurrent = case mipkg :: Maybe InstalledPackageEx of - Nothing -> \_ -> False - Just ipkg -> \p -> packageId p `elem` sourceDeps ipkg - -- If there is no upper bound on the version range then we apply a - -- preferred version according to the hackage or user's suggested - -- version constraints. TODO: distinguish hacks from prefs - bounded = boundedAbove versionRange - isPreferred p - | bounded = boundedRank -- this is a dummy constant - | otherwise = length . filter (packageVersion p `withinRange`) $ - preferredVersions - where (PackagePreferences preferredVersions _ _) = pref (packageName p) - boundedRank = 0 -- any value will do - - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of - (_, UpperBound _ _) -> True - (_, NoUpperBound ) -> False - - -- We really only expect to find more than one choice remaining when - -- we're finalising a dependency on a paired package. - checkIsPaired [p1, p2] = - case Constraints.isPaired constraints (packageId p1) of - Just p2' -> packageId p2' == packageId p2 - Nothing -> False - checkIsPaired _ = False - --- | Improve an existing installation plan by, where possible, swapping --- packages we plan to install with ones that are already installed. --- This may add additional constraints due to the dependencies of installed --- packages on other installed packages. --- -improvePlan :: PackageIndex InstalledPackage - -> Constraints - -> PackageIndex FinalSelectedPackage - -> (PackageIndex FinalSelectedPackage, Constraints) -improvePlan installed constraints0 selected0 = - foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) - where - improve (selected, constraints) = fromMaybe (selected, constraints) - . improvePkg selected constraints - - -- The idea is to improve the plan by swapping a configured package for - -- an equivalent installed one. For a particular package the condition is - -- that the package be in a configured state, that a the same version be - -- already installed with the exact same dependencies and all the packages - -- in the plan that it depends on are in the installed state - improvePkg selected constraints pkgid = do - SelectedSource pkg <- PackageIndex.lookupPackageId selected pkgid - ipkg <- PackageIndex.lookupPackageId installed pkgid - guard $ all (isInstalled selected) (sourceDeps pkg) - tryInstalled selected constraints [ipkg] - - isInstalled selected pkgid = - case PackageIndex.lookupPackageId selected pkgid of - Just (SelectedInstalled _) -> True - _ -> False - - tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints - -> [InstalledPackage] - -> Maybe (PackageIndex FinalSelectedPackage, Constraints) - tryInstalled selected constraints [] = Just (selected, constraints) - tryInstalled selected constraints (pkg:pkgs) = - case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of - Nothing -> Nothing - Just constraints' -> tryInstalled selected' constraints' pkgs' - where - selected' = PackageIndex.insert (SelectedInstalled pkg) selected - pkgs' = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs - notSelected pkgid = - case (PackageIndex.lookupPackageId installed pkgid - ,PackageIndex.lookupPackageId selected pkgid) of - (Just pkg', Nothing) -> Just pkg' - _ -> Nothing - - constraintsOk _ [] constraints = Just constraints - constraintsOk pkgid (pkgid':pkgids) constraints = - case addPackageDependencyConstraint pkgid dep True constraints of - Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' - _ -> Nothing - where - dep = thisPackageVersion pkgid' - - reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId] - reverseTopologicalOrder index = map (packageId . toPkg) - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkg, _) = dependencyGraph index - --- ------------------------------------------------------------ --- * Adding and recording constraints --- ------------------------------------------------------------ - -addPackageSelectConstraint :: PackageId -> Constraints - -> Satisfiable Constraints - [PackageId] ExclusionReason -addPackageSelectConstraint pkgid = - Constraints.constrain pkgname constraint reason - where - pkgname = packageName pkgid - constraint ver _ = ver == packageVersion pkgid - reason = SelectedOther pkgid - -addPackageExcludeConstraint :: PackageId -> ExclusionReason - -> Constraints - -> Satisfiable Constraints - [PackageId] ExclusionReason -addPackageExcludeConstraint pkgid reason = - Constraints.constrain pkgname constraint reason - where - pkgname = packageName pkgid - constraint ver installed - | ver == packageVersion pkgid = installed - | otherwise = True - -addPackageDependencyConstraint :: PackageId -> Dependency -> Bool - -> Constraints - -> Satisfiable Constraints - [PackageId] ExclusionReason -addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange) - installedConstraint = - Constraints.constrain pkgname constraint reason - where - constraint ver installed = ver `withinRange` verrange - && if installedConstraint then installed else True - reason = ExcludedByPackageDependency pkgid dep installedConstraint - -addTopLevelVersionConstraint :: PackageName -> VersionRange - -> Constraints - -> Satisfiable Constraints - [PackageId] ExclusionReason -addTopLevelVersionConstraint pkgname verrange = - Constraints.constrain pkgname constraint reason - where - constraint ver _installed = ver `withinRange` verrange - reason = ExcludedByTopLevelConstraintVersion pkgname verrange - -addTopLevelInstalledConstraint, - addTopLevelSourceConstraint :: PackageName - -> Constraints - -> Satisfiable Constraints - [PackageId] ExclusionReason -addTopLevelInstalledConstraint pkgname = - Constraints.constrain pkgname constraint reason - where - constraint _ver installed = installed - reason = ExcludedByTopLevelConstraintInstalled pkgname - -addTopLevelSourceConstraint pkgname = - Constraints.constrain pkgname constraint reason - where - constraint _ver installed = not installed - reason = ExcludedByTopLevelConstraintSource pkgname - - --- ------------------------------------------------------------ --- * Reasons for constraints --- ------------------------------------------------------------ - --- | For every constraint we record we also record the reason that constraint --- is needed. So if we end up failing due to conflicting constraints then we --- can give an explnanation as to what was conflicting and why. --- -data ExclusionReason = - - -- | We selected this other version of the package. That means we exclude - -- all the other versions. - SelectedOther PackageId - - -- | We excluded this version of the package because it failed to - -- configure probably because of unsatisfiable deps. - | ExcludedByConfigureFail [Dependency] - - -- | We excluded this version of the package because another package that - -- we selected imposed a dependency which this package did not satisfy. - | ExcludedByPackageDependency PackageId Dependency Bool - - -- | We excluded this version of the package because it did not satisfy - -- a dependency given as an original top level input. - -- - | ExcludedByTopLevelConstraintVersion PackageName VersionRange - | ExcludedByTopLevelConstraintInstalled PackageName - | ExcludedByTopLevelConstraintSource PackageName - - deriving Eq - --- | Given an excluded package and the reason it was excluded, produce a human --- readable explanation. --- -showExclusionReason :: PackageId -> ExclusionReason -> String -showExclusionReason pkgid (SelectedOther pkgid') = - display pkgid ++ " was excluded because " ++ - display pkgid' ++ " was selected instead" -showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) = - display pkgid ++ " was excluded because it could not be configured. " - ++ "It requires " ++ listOf displayDep missingDeps -showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint) - = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires " - ++ (if installedConstraint then "an installed instance of " else "") - ++ displayDep dep -showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) = - display pkgid ++ " was excluded because of the top level constraint " ++ - displayDep (Dependency pkgname verRange) -showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname) - = display pkgid ++ " was excluded because of the top level constraint '" - ++ display pkgname ++ " installed' which means that only installed instances " - ++ "of the package may be selected." -showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname) - = display pkgid ++ " was excluded because of the top level constraint '" - ++ display pkgname ++ " source' which means that only source versions " - ++ "of the package may be selected." - - --- ------------------------------------------------------------ --- * Logging progress and failures --- ------------------------------------------------------------ - -data Log = Select [SelectedPackage] [PackageId] - | AppliedVersionConstraint PackageName VersionRange [PackageId] - | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId] - | ExcludeUnconfigurable PackageId - -data Failure - = NoSuchPackage - PackageName - | ConfigureFailed - SelectablePackage - [(Dependency, [(PackageId, [ExclusionReason])])] - | DependencyConflict - SelectedPackage Dependency Bool - [(PackageId, [ExclusionReason])] - | TopLevelVersionConstraintConflict - PackageName VersionRange - [(PackageId, [ExclusionReason])] - | TopLevelVersionConstraintUnsatisfiable - PackageName VersionRange - | TopLevelInstallConstraintConflict - PackageName InstalledConstraint - [(PackageId, [ExclusionReason])] - | TopLevelInstallConstraintUnsatisfiable - PackageName InstalledConstraint - -showLog :: Log -> String -showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of - ("", y) -> y - (x, "") -> x - (x, y) -> x ++ " and " ++ y - - where - selectedMsg = "selecting " ++ case selected of - [] -> "" - [s] -> display (packageId s) ++ " " ++ kind s - (s:ss) -> listOf id - $ (display (packageId s) ++ " " ++ kind s) - : [ display (packageVersion s') ++ " " ++ kind s' - | s' <- ss ] - - kind (InstalledOnly _) = "(installed)" - kind (SourceOnly _) = "(source)" - kind (InstalledAndSource _ _) = "(installed or source)" - - discardedMsg = case discarded of - [] -> "" - _ -> "discarding " ++ listOf id - [ element - | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) - , element <- display pkgid : map (display . packageVersion) pkgids ] -showLog (AppliedVersionConstraint pkgname ver pkgids) = - "applying constraint " ++ display (Dependency pkgname ver) - ++ if null pkgids - then "" - else " which excludes " ++ listOf display pkgids -showLog (AppliedInstalledConstraint pkgname inst pkgids) = - "applying constraint " ++ display pkgname ++ " '" - ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' " - ++ if null pkgids - then "" - else "which excludes " ++ listOf display pkgids -showLog (ExcludeUnconfigurable pkgid) = - "excluding " ++ display pkgid ++ " (it cannot be configured)" - -showFailure :: Failure -> String -showFailure (NoSuchPackage pkgname) = - "The package " ++ display pkgname ++ " is unknown." -showFailure (ConfigureFailed pkg missingDeps) = - "cannot configure " ++ displayPkg pkg ++ ". It requires " - ++ listOf (displayDep . fst) missingDeps - ++ '\n' : unlines (map (uncurry whyNot) missingDeps) - - where - whyNot (Dependency name ver) [] = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - - whyNot dep conflicts = - "For the dependency on " ++ displayDep dep - ++ " there are these packages: " ++ listOf display pkgs - ++ ". However none of them are available.\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - - where pkgs = map fst conflicts - -showFailure (DependencyConflict pkg dep installedConstraint conflicts) = - "dependencies conflict: " - ++ displayPkg pkg ++ " requires " - ++ (if installedConstraint then "an installed instance of " else "") - ++ displayDep dep ++ " however:\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintConflict name ver conflicts) = - "constraints conflict: we have the top level constraint " - ++ displayDep (Dependency name ver) ++ ", but\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - -showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) = - "constraints conflict: " - ++ "top level constraint '" ++ display name ++ " installed' however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) = - "There is no installed version of " ++ display name - -showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) = - "constraints conflict: " - ++ "top level constraint '" ++ display name ++ " source' however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) = - "There is no available source version of " ++ display name - -displayVer :: VersionRange -> String -displayVer = display . simplifyVersionRange - -displayDep :: Dependency -> String -displayDep = display . simplifyDependency - - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -impossible :: String -> a -impossible msg = internalError $ "assertion failure: " ++ msg - -internalError :: String -> a -internalError msg = error $ "internal error: " ++ msg - -displayPkg :: Package pkg => pkg -> String -displayPkg = display . packageId - -listOf :: (a -> String) -> [a] -> String -listOf _ [] = [] -listOf disp [x0] = disp x0 -listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs - where go x [] = " and " ++ disp x - go x (x':xs') = ", " ++ disp x ++ go x' xs' - --- ------------------------------------------------------------ --- * Construct a dependency graph --- ------------------------------------------------------------ - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- --- The top-down solver gets its own implementation, because both --- `dependencyGraph` in `Distribution.Client.PlanIndex` (in cabal-install) and --- `dependencyGraph` in `Distribution.Simple.PackageIndex` (in Cabal) both work --- with `PackageIndex` from `Cabal` (that is, a package index indexed by --- installed package IDs rather than package names). --- --- Ideally we would switch the top-down solver over to use that too, so that --- this duplication could be avoided, but that's a bit of work and the top-down --- solver is legacy code anyway. --- --- (NOTE: This is called at two types: InstalledPackage and FinalSelectedPackage.) -dependencyGraph :: PackageSourceDeps pkg - => PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> pkg, - PackageId -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) - where - graph = Array.listArray bounds $ - map (catMaybes . map pkgIdToVertex . sourceDeps) pkgs - vertexToPkg vertex = pkgTable Array.! vertex - pkgIdToVertex = binarySearch 0 topBound - - pkgTable = Array.listArray bounds pkgs - pkgIdTable = Array.listArray bounds (map packageId pkgs) - pkgs = sortBy (comparing packageId) (PackageIndex.allPackages index) - topBound = length pkgs - 1 - bounds = (0, topBound) - - binarySearch a b key - | a > b = Nothing - | otherwise = case compare key (pkgIdTable Array.! mid) of - LT -> binarySearch a (mid-1) key - EQ -> Just mid - GT -> binarySearch (mid+1) b key - where mid = (a + b) `div` 2 diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/TopDown/Constraints.hs +++ /dev/null @@ -1,599 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.TopDown.Constraints --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- A set of satisfiable constraints on a set of packages. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.TopDown.Constraints ( - Constraints, - empty, - packages, - choices, - isPaired, - - addTarget, - constrain, - Satisfiable(..), - conflicting, - ) where - -import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Package - ( PackageName, PackageId, PackageIdentifier(..) - , Package(packageId), packageName, packageVersion - , Dependency ) -import Distribution.Version - ( Version ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( Monoid(mempty) ) -#endif -import Data.Either - ( partitionEithers ) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Set as Set -import Data.Set (Set) -import Control.Exception - ( assert ) - - --- | A set of satisfiable constraints on a set of packages. --- --- The 'Constraints' type keeps track of a set of targets (identified by --- package name) that we know that we need. It also keeps track of a set of --- constraints over all packages in the environment. --- --- It maintains the guarantee that, for the target set, the constraints are --- satisfiable, meaning that there is at least one instance available for each --- package name that satisfies the constraints on that package name. --- --- Note that it is possible to over-constrain a package in the environment that --- is not in the target set -- the satisfiability guarantee is only maintained --- for the target set. This is useful because it allows us to exclude packages --- without needing to know if it would ever be needed or not (e.g. allows --- excluding broken installed packages). --- --- Adding a constraint for a target package can fail if it would mean that --- there are no remaining choices. --- --- Adding a constraint for package that is not a target never fails. --- --- Adding a new target package can fail if that package already has conflicting --- constraints. --- -data Constraints installed source reason - = Constraints - - -- | Targets that we know we need. This is the set for which we - -- guarantee the constraints are satisfiable. - !(Set PackageName) - - -- | The available/remaining set. These are packages that have available - -- choices remaining. This is guaranteed to cover the target packages, - -- but can also cover other packages in the environment. New targets can - -- only be added if there are available choices remaining for them. - !(PackageIndex (InstalledOrSource installed source)) - - -- | The excluded set. Choices that we have excluded by applying - -- constraints. Excluded choices are tagged with the reason. - !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason)) - - -- | Paired choices, this is an ugly hack. - !(Map PackageName (Version, Version)) - - -- | Purely for the invariant, we keep a copy of the original index - !(PackageIndex (InstalledOrSource installed source)) - - --- | Reasons for excluding all, or some choices for a package version. --- --- Each package version can have a source instance, an installed instance or --- both. We distinguish reasons for constraints that excluded both instances, --- from reasons for constraints that excluded just one instance. --- -data ExcludedPkg pkg reason - = ExcludedPkg pkg - [reason] -- ^ reasons for excluding both source and installed instances - [reason] -- ^ reasons for excluding the installed instance - [reason] -- ^ reasons for excluding the source instance - -instance Package pkg => Package (ExcludedPkg pkg reason) where - packageId (ExcludedPkg p _ _ _) = packageId p - - --- | There is a conservation of packages property. Packages are never gained or --- lost, they just transfer from the remaining set to the excluded set. --- -invariant :: (Package installed, Package source) - => Constraints installed source a -> Bool -invariant (Constraints targets available excluded _ original) = - - -- Relationship between available, excluded and original - all check merged - - -- targets is a subset of available - && all (PackageIndex.elemByPackageName available) (Set.elems targets) - - where - merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) - (PackageIndex.allPackages original) - (mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages excluded)) - where - mergedPackageId (OnlyInLeft p ) = packageId p - mergedPackageId (OnlyInRight p) = packageId p - mergedPackageId (InBoth p _) = packageId p - - -- If the package was originally installed only, then - check (InBoth (InstalledOnly _) cur) = case cur of - -- now it's either still remaining as installed only - OnlyInLeft (InstalledOnly _) -> True - -- or it has been excluded - OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True - _ -> False - - -- If the package was originally available only, then - check (InBoth (SourceOnly _) cur) = case cur of - -- now it's either still remaining as source only - OnlyInLeft (SourceOnly _) -> True - -- or it has been excluded - OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True - _ -> False - - -- If the package was originally installed and source, then - check (InBoth (InstalledAndSource _ _) cur) = case cur of - -- We can have both remaining: - OnlyInLeft (InstalledAndSource _ _) -> True - - -- both excluded, in particular it can have had the just source or - -- installed excluded and later had both excluded so we do not mind if - -- the source or installed excluded is empty or non-empty. - OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True - - -- the installed remaining and the source excluded: - InBoth (InstalledOnly _) - (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True - - -- the source remaining and the installed excluded: - InBoth (SourceOnly _) - (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True - _ -> False - - check _ = False - - --- | An update to the constraints can move packages between the two piles --- but not gain or loose packages. -transitionsTo :: (Package installed, Package source) - => Constraints installed source a - -> Constraints installed source a -> Bool -transitionsTo constraints @(Constraints _ available excluded _ _) - constraints'@(Constraints _ available' excluded' _ _) = - - invariant constraints && invariant constraints' - && null availableGained && null excludedLost - && map (mapInstalledOrSource packageId packageId) availableLost - == map (mapInstalledOrSource packageId packageId) excludedGained - - where - (availableLost, availableGained) - = partitionEithers (foldr lostAndGained [] availableChange) - - (excludedLost, excludedGained) - = partitionEithers (foldr lostAndGained [] excludedChange) - - availableChange = - mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages available') - - excludedChange = - mergeBy (\a b -> packageId a `compare` packageId b) - [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ] - [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ] - - lostAndGained mr rest = case mr of - OnlyInLeft pkg -> Left pkg : rest - InBoth (InstalledAndSource pkg _) - (SourceOnly _) -> Left (InstalledOnly pkg) : rest - InBoth (InstalledAndSource _ pkg) - (InstalledOnly _) -> Left (SourceOnly pkg) : rest - InBoth (SourceOnly _) - (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest - InBoth (InstalledOnly _) - (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest - OnlyInRight pkg -> Right pkg : rest - _ -> rest - - mapInstalledOrSource f g pkg = case pkg of - InstalledOnly a -> InstalledOnly (f a) - SourceOnly b -> SourceOnly (g b) - InstalledAndSource a b -> InstalledAndSource (f a) (g b) - --- | We construct 'Constraints' with an initial 'PackageIndex' of all the --- packages available. --- -empty :: PackageIndex InstalledPackageEx - -> PackageIndex UnconfiguredPackage - -> Constraints InstalledPackageEx UnconfiguredPackage reason -empty installed source = - Constraints targets pkgs excluded pairs pkgs - where - targets = mempty - excluded = mempty - pkgs = PackageIndex.fromList - . map toInstalledOrSource - $ mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages installed) - (PackageIndex.allPackages source) - toInstalledOrSource (OnlyInLeft i ) = InstalledOnly i - toInstalledOrSource (OnlyInRight a) = SourceOnly a - toInstalledOrSource (InBoth i a) = InstalledAndSource i a - - -- pick up cases like base-3 and 4 where one version depends on the other: - pairs = Map.fromList - [ (name, (packageVersion pkgid1, packageVersion pkgid2)) - | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed - , let name = packageName pkg1 - pkgid1 = packageId pkg1 - pkgid2 = packageId pkg2 - , any ((pkgid1==) . packageId) (sourceDeps pkg2) - || any ((pkgid2==) . packageId) (sourceDeps pkg1) ] - - --- | The package targets. --- -packages :: Constraints installed source reason - -> Set PackageName -packages (Constraints ts _ _ _ _) = ts - - --- | The package choices that are still available. --- -choices :: Constraints installed source reason - -> PackageIndex (InstalledOrSource installed source) -choices (Constraints _ available _ _ _) = available - -isPaired :: Constraints installed source reason - -> PackageId -> Maybe PackageId -isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) = - case Map.lookup name pairs of - Just (v1, v2) - | version == v1 -> Just (PackageIdentifier name v2) - | version == v2 -> Just (PackageIdentifier name v1) - _ -> Nothing - - -data Satisfiable constraints discarded reason - = Satisfiable constraints discarded - | Unsatisfiable - | ConflictsWith [(PackageId, [reason])] - - -addTarget :: (Package installed, Package source) - => PackageName - -> Constraints installed source reason - -> Satisfiable (Constraints installed source reason) - () reason -addTarget pkgname - constraints@(Constraints targets available excluded paired original) - - -- If it's already a target then there's no change - | pkgname `Set.member` targets - = Satisfiable constraints () - - -- If there is some possible choice available for this target then we're ok - | PackageIndex.elemByPackageName available pkgname - = let targets' = Set.insert pkgname targets - constraints' = Constraints targets' available excluded paired original - in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' () - - -- If it's not available and it is excluded then we return the conflicts - | PackageIndex.elemByPackageName excluded pkgname - = ConflictsWith conflicts - - -- Otherwise, it's not available and it has not been excluded so the - -- package is simply completely unknown. - | otherwise - = Unsatisfiable - - where - conflicts = - [ (packageId pkg, reasons) - | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname - , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices - , let reasons = isReasons ++ iReasons ++ sReasons ] - - -constrain :: (Package installed, Package source) - => PackageName -- ^ which package to constrain - -> (Version -> Bool -> Bool) -- ^ the constraint test - -> reason -- ^ the reason for the constraint - -> Constraints installed source reason - -> Satisfiable (Constraints installed source reason) - [PackageId] reason -constrain pkgname constraint reason - constraints@(Constraints targets available excluded paired original) - - | pkgname `Set.member` targets && not anyRemaining - = if null conflicts then Unsatisfiable - else ConflictsWith conflicts - - | otherwise - = let constraints' = Constraints targets available' excluded' paired original - in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' (map packageId newExcluded) - - where - -- This tells us if any packages would remain at all for this package name if - -- we applied this constraint. This amounts to checking if any package - -- satisfies the given constraint, including version range and installation - -- status. - -- - (available', excluded', newExcluded, anyRemaining, conflicts) = - updatePkgsStatus - available excluded - [] False [] - (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg') - (PackageIndex.lookupPackageName available pkgname) - (PackageIndex.lookupPackageName excluded pkgname)) - - testConstraint pkg = - let ver = packageVersion pkg in - case Map.lookup (packageName pkg) paired of - - Just (v1, v2) - | ver == v1 || ver == v2 - -> case pkg of - InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) - SourceOnly spkg -> SourceOnly (spkg, sOk) - InstalledAndSource ipkg spkg -> - InstalledAndSource (ipkg, iOk) (spkg, sOk) - where - iOk = constraint v1 True || constraint v2 True - sOk = constraint v1 False || constraint v2 False - - _ -> case pkg of - InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) - SourceOnly spkg -> SourceOnly (spkg, sOk) - InstalledAndSource ipkg spkg -> - InstalledAndSource (ipkg, iOk) (spkg, sOk) - where - iOk = constraint ver True - sOk = constraint ver False - - -- For the info about available and excluded versions of the package in - -- question, update the info given the current constraint - -- - -- We update the available package map and the excluded package map - -- we also collect: - -- * the change in available packages (for logging) - -- * whether there are any remaining choices - -- * any constraints that conflict with the current constraint - - updatePkgsStatus _ _ nePkgs ok cs _ - | seq nePkgs $ seq ok $ seq cs False = undefined - - updatePkgsStatus aPkgs ePkgs nePkgs ok cs [] - = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs) - - updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) = - let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg - nePkgs' = maybeCons mnePkg nePkgs - cs' = maybeCons mc cs - in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs - - maybeCons Nothing xs = xs - maybeCons (Just x) xs = x:xs - - - -- For the info about an available or excluded version of the package in - -- question, update the info given the current constraint. - -- - updatePkgStatus aPkgs ePkgs pkg = - case viewPackageStatus pkg of - AllAvailable (InstalledOnly (aiPkg, False)) -> - removeAvailable False - (InstalledOnly aiPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) - Nothing - - AllAvailable (SourceOnly (asPkg, False)) -> - removeAvailable False - (SourceOnly asPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) - Nothing - - AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) -> - removeAvailable False - (InstalledAndSource aiPkg asPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] []) - Nothing - - AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) -> - removeAvailable True - (SourceOnly asPkg) - (PackageIndex.insert (InstalledOnly aiPkg)) - (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) - Nothing - - AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) -> - removeAvailable True - (InstalledOnly aiPkg) - (PackageIndex.insert (SourceOnly asPkg)) - (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) - Nothing - - AllAvailable _ -> noChange True Nothing - - AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) -> - removeAvailable False - (InstalledOnly aiPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs) - Nothing - - AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) -> - addExtraExclusion True - (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) - Nothing - - AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) -> - removeAvailable True - (InstalledOnly aiPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs) - (Just (pkgid, srs)) - - AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) -> - noChange True - (Just (pkgid, srs)) - - ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) -> - removeAvailable False - (SourceOnly asPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs []) - Nothing - - ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) -> - removeAvailable False - (SourceOnly asPkg) - (PackageIndex.deletePackageId pkgid) - (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason]) - (Just (pkgid, irs)) - - ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) -> - addExtraExclusion True - (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) - Nothing - - ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) -> - noChange True - (Just (pkgid, irs)) - - AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) -> - addExtraExclusion False - (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) - Nothing - - AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) -> - noChange False - (Just (pkgid, irs)) - - AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) -> - addExtraExclusion False - (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) - Nothing - - AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) -> - noChange False - (Just (pkgid, srs)) - - AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) -> - addExtraExclusion False - (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs) - Nothing - - AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) -> - addExtraExclusion False - (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs)) - (Just (pkgid, irs)) - - AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) -> - addExtraExclusion False - (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs) - (Just (pkgid, srs)) - - AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) -> - noChange False - (Just (pkgid, isrs ++ irs ++ srs)) - - where - removeAvailable ok nePkg adjustAvailable ePkg c = - let aPkgs' = adjustAvailable aPkgs - ePkgs' = PackageIndex.insert ePkg ePkgs - in aPkgs' `seq` ePkgs' `seq` - (aPkgs', ePkgs', Just nePkg, ok, c) - - addExtraExclusion ok ePkg c = - let ePkgs' = PackageIndex.insert ePkg ePkgs - in ePkgs' `seq` - (aPkgs, ePkgs', Nothing, ok, c) - - noChange ok c = - (aPkgs, ePkgs, Nothing, ok, c) - - pkgid = case pkg of OnlyInLeft p -> packageId p - OnlyInRight p -> packageId p - InBoth p _ -> packageId p - - - viewPackageStatus - :: (Package installed, Package source) - => MergeResult (InstalledOrSource installed source) - (ExcludedPkg (InstalledOrSource installed source) reason) - -> PackageStatus (installed, Bool) (source, Bool) reason - viewPackageStatus merged = - case merged of - OnlyInLeft aPkg -> - AllAvailable (testConstraint aPkg) - - OnlyInRight (ExcludedPkg ePkg isrs irs srs) -> - AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs) - - InBoth (InstalledOnly aiPkg) - (ExcludedPkg (SourceOnly esPkg) [] [] srs) -> - case testConstraint (InstalledAndSource aiPkg esPkg) of - InstalledAndSource (aiPkg', iOk) (esPkg', sOk) -> - AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs) - _ -> impossible - - InBoth (SourceOnly asPkg) - (ExcludedPkg (InstalledOnly eiPkg) [] irs []) -> - case testConstraint (InstalledAndSource eiPkg asPkg) of - InstalledAndSource (eiPkg', iOk) (asPkg', sOk) -> - ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk) - _ -> impossible - _ -> impossible - where - impossible = error "impossible: viewPackageStatus invariant violation" - --- A intermediate structure that enumerates all the possible cases given the --- invariant. This helps us to get simpler and complete pattern matching in --- updatePkg above --- -data PackageStatus installed source reason - = AllAvailable (InstalledOrSource installed source) - | AllExcluded (ExcludedPkg (InstalledOrSource installed source) reason) - | AvailableExcluded installed (ExcludedPkg source reason) - | ExcludedAvailable (ExcludedPkg installed reason) source - - -conflicting :: (Package installed, Package source) - => Constraints installed source reason - -> Dependency - -> [(PackageId, [reason])] -conflicting (Constraints _ _ excluded _ _) dep = - [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO - | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <- - PackageIndex.lookupDependency excluded dep ] diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/TopDown/Types.hs +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.TopDown.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Types for the top-down dependency resolver. ------------------------------------------------------------------------------ -{-# LANGUAGE CPP #-} -module Distribution.Client.Dependency.TopDown.Types where - -import Distribution.Client.Types - ( SourcePackage(..), ConfiguredPackage(..) - , OptionalStanza, ConfiguredId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import qualified Distribution.Client.ComponentDeps as CD - -import Distribution.Package - ( PackageId, PackageIdentifier, Dependency - , Package(packageId) ) -import Distribution.PackageDescription - ( FlagAssignment ) - --- ------------------------------------------------------------ --- * The various kinds of packages --- ------------------------------------------------------------ - -type SelectablePackage - = InstalledOrSource InstalledPackageEx UnconfiguredPackage - -type SelectedPackage - = InstalledOrSource InstalledPackageEx SemiConfiguredPackage - -data InstalledOrSource installed source - = InstalledOnly installed - | SourceOnly source - | InstalledAndSource installed source - deriving Eq - -data FinalSelectedPackage - = SelectedInstalled InstalledPackage - | SelectedSource ConfiguredPackage - -type TopologicalSortNumber = Int - --- | InstalledPackage caches its dependencies as source package IDs. -data InstalledPackage - = InstalledPackage - InstalledPackageInfo - [PackageId] - -data InstalledPackageEx - = InstalledPackageEx - InstalledPackage - !TopologicalSortNumber - [PackageIdentifier] -- transitive closure of installed deps - -data UnconfiguredPackage - = UnconfiguredPackage - SourcePackage - !TopologicalSortNumber - FlagAssignment - [OptionalStanza] - -data SemiConfiguredPackage - = SemiConfiguredPackage - SourcePackage -- package info - FlagAssignment -- total flag assignment for the package - [OptionalStanza] -- enabled optional stanzas - [Dependency] -- dependencies we end up with when we apply - -- the flag assignment - -instance Package InstalledPackage where - packageId (InstalledPackage pkg _) = packageId pkg - -instance Package InstalledPackageEx where - packageId (InstalledPackageEx p _ _) = packageId p - -instance Package UnconfiguredPackage where - packageId (UnconfiguredPackage p _ _ _) = packageId p - -instance Package SemiConfiguredPackage where - packageId (SemiConfiguredPackage p _ _ _) = packageId p - -instance (Package installed, Package source) - => Package (InstalledOrSource installed source) where - packageId (InstalledOnly p ) = packageId p - packageId (SourceOnly p ) = packageId p - packageId (InstalledAndSource p _) = packageId p - -instance Package FinalSelectedPackage where - packageId (SelectedInstalled pkg) = packageId pkg - packageId (SelectedSource pkg) = packageId pkg - - --- | We can have constraints on selecting just installed or just source --- packages. --- --- In particular, installed packages can only depend on other installed --- packages while packages that are not yet installed but which we plan to --- install can depend on installed or other not-yet-installed packages. --- -data InstalledConstraint = InstalledConstraint - | SourceConstraint - deriving (Eq, Show) - --- | Package dependencies --- --- The top-down solver uses its down type class for package dependencies, --- because it wants to know these dependencies as PackageIds, rather than as --- ComponentIds (so it cannot use PackageFixedDeps). --- --- Ideally we would switch the top-down solver over to use ComponentIds --- throughout; that means getting rid of this type class, and changing over the --- package index type to use Cabal's rather than cabal-install's. That will --- avoid the need for the local definitions of dependencyGraph and --- reverseTopologicalOrder in the top-down solver. --- --- Note that the top-down solver does not (and probably will never) make a --- distinction between the various kinds of dependencies, so we return a flat --- list here. If we get rid of this type class then any use of `sourceDeps` --- should be replaced by @fold . depends@. -class Package a => PackageSourceDeps a where - sourceDeps :: a -> [PackageIdentifier] - -instance PackageSourceDeps InstalledPackageEx where - sourceDeps (InstalledPackageEx _ _ deps) = deps - -instance PackageSourceDeps ConfiguredPackage where - sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps - -instance PackageSourceDeps InstalledPackage where - sourceDeps (InstalledPackage _ deps) = deps - -instance PackageSourceDeps FinalSelectedPackage where - sourceDeps (SelectedInstalled pkg) = sourceDeps pkg - sourceDeps (SelectedSource pkg) = sourceDeps pkg - 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,193 +1,45 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ module Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..), - DependencyResolver, - ResolverPackage(..), - PackageConstraint(..), - showPackageConstraint, - PackagePreferences(..), - InstalledPreference(..), PackagesPreferenceDefault(..), - Progress(..), - foldProgress, - - LabeledPackageConstraint(..), - ConstraintSource(..), - unlabelPackageConstraint, - showConstraintSource - ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative - ( Applicative(..) ) -#endif -import Control.Applicative - ( Alternative(..) ) - import Data.Char ( isAlpha, toLower ) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( Monoid(..) ) -#endif -import Distribution.Client.PkgConfigDb - ( PkgConfigDb ) -import Distribution.Client.Types - ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage ) - import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 ) -import Distribution.PackageDescription - ( FlagAssignment, FlagName(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import qualified Distribution.Client.PackageIndex as PackageIndex - ( PackageIndex ) -import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) -import Distribution.Package - ( PackageName ) -import Distribution.Version - ( VersionRange, simplifyVersionRange ) -import Distribution.Compiler - ( CompilerInfo ) -import Distribution.System - ( Platform ) import Distribution.Text - ( Text(..), display ) + ( Text(..) ) import Text.PrettyPrint ( text ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) -import Prelude hiding (fail) - -- | All the solvers that can be selected. -data PreSolver = AlwaysTopDown | AlwaysModular | Choose +data PreSolver = AlwaysModular deriving (Eq, Ord, Show, Bounded, Enum, Generic) -- | All the solvers that can be used. -data Solver = TopDown | Modular +data Solver = Modular deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance Binary PreSolver instance Binary Solver instance Text PreSolver where - disp AlwaysTopDown = text "topdown" disp AlwaysModular = text "modular" - disp Choose = text "choose" parse = do name <- Parse.munch1 isAlpha case map toLower name of - "topdown" -> return AlwaysTopDown "modular" -> return AlwaysModular - "choose" -> return Choose _ -> Parse.pfail --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. --- --- The reason for this interface is because there are dozens of approaches to --- solving the package dependency problem and we want to make it easy to swap --- in alternatives. --- -type DependencyResolver = Platform - -> CompilerInfo - -> InstalledPackageIndex - -> PackageIndex.PackageIndex SourcePackage - -> PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> [PackageName] - -> Progress String String [ResolverPackage] - --- | The dependency resolver picks either pre-existing installed packages --- or it picks source packages along with package configuration. --- --- This is like the 'InstallPlan.PlanPackage' but with fewer cases. --- -data ResolverPackage = PreExisting InstalledPackageInfo - | Configured ConfiguredPackage - --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageConstraintVersion PackageName VersionRange - | PackageConstraintInstalled PackageName - | PackageConstraintSource PackageName - | PackageConstraintFlags PackageName FlagAssignment - | PackageConstraintStanzas PackageName [OptionalStanza] - deriving (Eq,Show,Generic) - -instance Binary PackageConstraint - --- | Provide a textual representation of a package constraint --- for debugging purposes. --- -showPackageConstraint :: PackageConstraint -> String -showPackageConstraint (PackageConstraintVersion pn vr) = - display pn ++ " " ++ display (simplifyVersionRange vr) -showPackageConstraint (PackageConstraintInstalled pn) = - display pn ++ " installed" -showPackageConstraint (PackageConstraintSource pn) = - display pn ++ " source" -showPackageConstraint (PackageConstraintFlags pn fs) = - "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs) - where - showFlag (FlagName f) True = "+" ++ f - showFlag (FlagName f) False = "-" ++ f -showPackageConstraint (PackageConstraintStanzas pn ss) = - "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss) - where - showStanza TestStanzas = "test" - showStanza BenchStanzas = "bench" - --- | Per-package preferences on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. It consists of --- an 'InstalledPreference' which says if we prefer versions of packages --- that are already installed. It also has (possibly multiple) --- 'PackageVersionPreference's which are suggested constraints on the version --- number. The resolver should try to use package versions that satisfy --- the maximum number of the suggested version constraints. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackagePreferences = PackagePreferences [VersionRange] - InstalledPreference - [OptionalStanza] - --- | Whether we prefer an installed version of a package or simply the latest --- version. --- -data InstalledPreference = PreferInstalled | PreferLatest - deriving Show - -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. -- @@ -212,107 +64,3 @@ -- | PreferLatestForSelected deriving Show - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail. We may get intermediate steps before the final --- result which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - deriving (Functor) - --- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two --- base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r - -instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p - -instance Applicative (Progress step fail) where - pure a = Done a - p <*> x = foldProgress Step Fail (flip fmap x) p - -instance Monoid fail => Alternative (Progress step fail) where - empty = Fail mempty - p <|> q = foldProgress Step (const q) Done p - --- | 'PackageConstraint' labeled with its source. -data LabeledPackageConstraint - = LabeledPackageConstraint PackageConstraint ConstraintSource - -unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint -unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc - --- | Source of a 'PackageConstraint'. -data ConstraintSource = - - -- | Main config file, which is ~/.cabal/config by default. - ConstraintSourceMainConfig FilePath - - -- | Local cabal.project file - | ConstraintSourceProjectConfig FilePath - - -- | Sandbox config file, which is ./cabal.sandbox.config by default. - | ConstraintSourceSandboxConfig FilePath - - -- | User config file, which is ./cabal.config by default. - | ConstraintSourceUserConfig FilePath - - -- | Flag specified on the command line. - | ConstraintSourceCommandlineFlag - - -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ - -- implies @package==0.1.0.0@. - | ConstraintSourceUserTarget - - -- | Internal requirement to use installed versions of packages like ghc-prim. - | ConstraintSourceNonUpgradeablePackage - - -- | Internal requirement to use the add-source version of a package when that - -- version is installed and the source is modified. - | ConstraintSourceModifiedAddSourceDep - - -- | Internal constraint used by @cabal freeze@. - | ConstraintSourceFreeze - - -- | Constraint specified by a config file, a command line flag, or a user - -- target, when a more specific source is not known. - | ConstraintSourceConfigFlagOrTarget - - -- | The source of the constraint is not specified. - | ConstraintSourceUnknown - deriving (Eq, Show, Generic) - -instance Binary ConstraintSource - --- | Description of a 'ConstraintSource'. -showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ path -showConstraintSource (ConstraintSourceSandboxConfig path) = - "sandbox config " ++ path -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonUpgradeablePackage = - "non-upgradeable package" -showConstraintSource ConstraintSourceModifiedAddSourceDep = - "modified add-source dependency" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceUnknown = "unknown source" diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -5,37 +5,83 @@ -- The layout of the .\/dist\/ directory where cabal keeps all of it's state -- and build artifacts. -- -module Distribution.Client.DistDirLayout where +module Distribution.Client.DistDirLayout ( + -- * 'DistDirLayout' + DistDirLayout(..), + DistDirParams(..), + defaultDistDirLayout, + ProjectRoot(..), + -- * 'StoreDirLayout' + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * 'CabalDirLayout' + CabalDirLayout(..), + defaultCabalDirLayout, +) where + +import Data.Maybe (fromMaybe) import System.FilePath + import Distribution.Package - ( PackageId ) + ( PackageId, ComponentId, UnitId ) import Distribution.Compiler -import Distribution.Simple.Compiler (PackageDB(..)) +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) import Distribution.Text -import Distribution.Client.Types - ( InstalledPackageId ) +import Distribution.Types.ComponentName +import Distribution.System +-- | Information which can be used to construct the path to +-- the build directory of a build. This is LESS fine-grained +-- than what goes into the hashed 'InstalledPackageId', +-- and for good reason: we don't want this path to change if +-- the user, say, adds a dependency to their project. +data DistDirParams = DistDirParams { + distParamUnitId :: UnitId, + distParamPackageId :: PackageId, + distParamComponentId :: ComponentId, + distParamComponentName :: Maybe ComponentName, + distParamCompilerId :: CompilerId, + distParamPlatform :: Platform, + distParamOptimization :: OptimisationLevel + -- TODO (see #3343): + -- Flag assignments + -- Optimization + } + -- | The layout of the project state directory. Traditionally this has been -- called the @dist@ directory. -- data DistDirLayout = DistDirLayout { - -- | The dist directory, which is the root of where cabal keeps all its - -- state including the build artifacts from each package we build. + -- | The root directory of the project. Many other files are relative to + -- this location. In particular, the @cabal.project@ lives here. -- + distProjectRootDirectory :: FilePath, + + -- | The @cabal.project@ file and related like @cabal.project.freeze@. + -- The parameter is for the extension, like \"freeze\", or \"\" for the + -- main file. + -- + distProjectFile :: String -> FilePath, + + -- | The \"dist\" directory, which is the root of where cabal keeps all + -- its state including the build artifacts from each package we build. + -- distDirectory :: FilePath, -- | The directory under dist where we keep the build artifacts for a -- package we're building from a local directory. -- - -- This uses a 'PackageId' not just a 'PackageName' because technically + -- This uses a 'UnitId' not just a 'PackageName' because technically -- we can have multiple instances of the same package in a solution -- (e.g. setup deps). -- - distBuildDirectory :: PackageId -> FilePath, + distBuildDirectory :: DistDirParams -> FilePath, distBuildRootDirectory :: FilePath, -- | The directory under dist where we put the unpacked sources of @@ -55,8 +101,8 @@ -- | The location for package-specific cache files (e.g. state used in -- incremental rebuilds). -- - distPackageCacheFile :: PackageId -> String -> FilePath, - distPackageCacheDirectory :: PackageId -> FilePath, + distPackageCacheFile :: DistDirParams -> String -> FilePath, + distPackageCacheDirectory :: DistDirParams -> FilePath, distTempDirectory :: FilePath, distBinDirectory :: FilePath, @@ -65,30 +111,91 @@ } +-- | The layout of a cabal nix-style store. +-- +data StoreDirLayout = StoreDirLayout { + storeDirectory :: CompilerId -> FilePath, + storePackageDirectory :: CompilerId -> UnitId -> FilePath, + storePackageDBPath :: CompilerId -> FilePath, + storePackageDB :: CompilerId -> PackageDB, + storePackageDBStack :: CompilerId -> PackageDBStack, + storeIncomingDirectory :: CompilerId -> FilePath, + storeIncomingLock :: CompilerId -> UnitId -> FilePath + } + --TODO: move to another module, e.g. CabalDirLayout? +-- or perhaps rename this module to DirLayouts. + +-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir +-- on unix, and equivalents on other systems. +-- +-- At the moment this is just a partial specification, but the idea is +-- eventually to cover it all. +-- data CabalDirLayout = CabalDirLayout { - cabalStoreDirectory :: CompilerId -> FilePath, - cabalStorePackageDirectory :: CompilerId -> InstalledPackageId - -> FilePath, - cabalStorePackageDBPath :: CompilerId -> FilePath, - cabalStorePackageDB :: CompilerId -> PackageDB, + cabalStoreDirLayout :: StoreDirLayout, - cabalPackageCacheDirectory :: FilePath, cabalLogsDirectory :: FilePath, cabalWorldFile :: FilePath } -defaultDistDirLayout :: FilePath -> DistDirLayout -defaultDistDirLayout projectRootDirectory = +-- | Information about the root directory of the project. +-- +-- It can either be an implict project root in the current dir if no +-- @cabal.project@ file is found, or an explicit root if the file is found. +-- +data ProjectRoot = + -- | -- ^ An implict project root. It contains the absolute project + -- root dir. + ProjectRootImplicit FilePath + + -- | -- ^ An explicit project root. It contains the absolute project + -- root dir and the relative @cabal.project@ file (or explicit override) + | ProjectRootExplicit FilePath FilePath + deriving (Eq, Show) + +-- | Make the default 'DistDirLayout' based on the project root dir and +-- optional overrides for the location of the @dist@ directory and the +-- @cabal.project@ file. +-- +defaultDistDirLayout :: ProjectRoot -- ^ the project root + -> Maybe FilePath -- ^ the @dist@ directory or default + -- (absolute or relative to the root) + -> DistDirLayout +defaultDistDirLayout projectRoot mdistDirectory = DistDirLayout {..} where - distDirectory = projectRootDirectory "dist-newstyle" + (projectRootDir, projectFile) = case projectRoot of + ProjectRootImplicit dir -> (dir, dir "cabal.project") + ProjectRootExplicit dir file -> (dir, dir file) + + distProjectRootDirectory = projectRootDir + distProjectFile ext = projectFile <.> ext + + distDirectory = distProjectRootDirectory + fromMaybe "dist-newstyle" mdistDirectory --TODO: switch to just dist at some point, or some other new name distBuildRootDirectory = distDirectory "build" - distBuildDirectory pkgid = distBuildRootDirectory display pkgid + distBuildDirectory params = + distBuildRootDirectory + display (distParamPlatform params) + display (distParamCompilerId params) + display (distParamPackageId params) + (case fmap componentNameString (distParamComponentName params) of + Nothing -> "" + Just Nothing -> "" + Just (Just name) -> "c" display name) + (case distParamOptimization params of + NoOptimisation -> "noopt" + NormalOptimisation -> "" + MaximumOptimisation -> "opt") + (let uid_str = display (distParamUnitId params) + in if uid_str == display (distParamComponentId params) + then "" + else uid_str) distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory @@ -97,8 +204,8 @@ distProjectCacheDirectory = distDirectory "cache" distProjectCacheFile name = distProjectCacheDirectory name - distPackageCacheDirectory pkgid = distBuildDirectory pkgid "cache" - distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid name + distPackageCacheDirectory params = distBuildDirectory params "cache" + distPackageCacheFile params name = distPackageCacheDirectory params name distTempDirectory = distDirectory "tmp" @@ -108,25 +215,38 @@ distPackageDB = SpecificPackageDB . distPackageDBPath - -defaultCabalDirLayout :: FilePath -> CabalDirLayout -defaultCabalDirLayout cabalDir = - CabalDirLayout {..} +defaultStoreDirLayout :: FilePath -> StoreDirLayout +defaultStoreDirLayout storeRoot = + StoreDirLayout {..} where + storeDirectory compid = + storeRoot display compid - cabalStoreDirectory compid = - cabalDir "store" display compid + storePackageDirectory compid ipkgid = + storeDirectory compid display ipkgid - cabalStorePackageDirectory compid ipkgid = - cabalStoreDirectory compid display ipkgid + storePackageDBPath compid = + storeDirectory compid "package.db" - cabalStorePackageDBPath compid = - cabalStoreDirectory compid "package.db" + storePackageDB compid = + SpecificPackageDB (storePackageDBPath compid) - cabalStorePackageDB = - SpecificPackageDB . cabalStorePackageDBPath + storePackageDBStack compid = + [GlobalPackageDB, storePackageDB compid] - cabalPackageCacheDirectory = cabalDir "packages" + storeIncomingDirectory compid = + storeDirectory compid "incoming" + + storeIncomingLock compid unitid = + storeIncomingDirectory compid display unitid <.> "lock" + + +defaultCabalDirLayout :: FilePath -> CabalDirLayout +defaultCabalDirLayout cabalDir = + CabalDirLayout {..} + where + + cabalStoreDirLayout = defaultStoreDirLayout (cabalDir "store") cabalLogsDirectory = cabalDir "logs" diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs --- a/Distribution/Client/Exec.hs +++ b/Distribution/Client/Exec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Exec @@ -12,7 +11,8 @@ module Distribution.Client.Exec ( exec ) where -import Control.Monad (unless) +import Prelude () +import Distribution.Client.Compat.Prelude import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS @@ -27,17 +27,14 @@ import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) -import Distribution.Simple.Utils (die, warn) +import Distribution.Simple.Utils (die', warn) -import Distribution.System (Platform) +import Distribution.System (Platform(..), OS(..), buildOS) import Distribution.Verbosity (Verbosity) import System.Directory ( doesDirectoryExist ) +import System.Environment (lookupEnv) import System.FilePath (searchPathSeparator, ()) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -import Data.Monoid (mempty) -#endif -- | Execute the given command in the package's environment. @@ -55,19 +52,19 @@ case extraArgs of (exe:args) -> do program <- requireProgram' verbosity useSandbox programDb exe - env <- ((++) (programOverrideEnv program)) <$> environmentOverrides + env <- environmentOverrides (programOverrideEnv program) let invocation = programInvocation program { programOverrideEnv = env } args runProgramInvocation verbosity invocation - [] -> die "Please specify an executable to run" + [] -> die' verbosity "Please specify an executable to run" where - environmentOverrides = + environmentOverrides env = case useSandbox of - NoSandbox -> return [] + NoSandbox -> return env (UseSandbox sandboxDir) -> - sandboxEnvironment verbosity sandboxDir comp platform programDb + sandboxEnvironment verbosity sandboxDir comp platform programDb env -- | Return the package's sandbox environment. @@ -78,13 +75,19 @@ -> Compiler -> Platform -> ProgramDb + -> [(String, Maybe String)] -- environment overrides so far -> IO [(String, Maybe String)] -sandboxEnvironment verbosity sandboxDir comp platform programDb = +sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv = case compilerFlavor comp of GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" - _ -> die "exec only works with GHC and GHCJS" + _ -> die' verbosity "exec only works with GHC and GHCJS" where + (Platform _ os) = platform + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + Windows -> "PATH" + _ -> "LD_LIBRARY_PATH" env getGlobalPackageDB hcProgram packagePathEnvVar = do let Just program = lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program @@ -96,14 +99,64 @@ exists <- doesDirectoryExist sandboxPackagePath unless exists $ warn verbosity $ "Package database is not a directory: " ++ sandboxPackagePath + -- MASSIVE HACK. We need this to be synchronized with installLibDir + -- in defaultInstallDirs' in Distribution.Simple.InstallDirs, + -- which has a special case for Windows (WHY? Who knows; it's been + -- around as long as Windows exists.) The sane thing to do here + -- would be to read out the actual install dirs that were associated + -- with the package in question, but that's not a well-formed question + -- here because there is not actually install directory for the + -- "entire" sandbox. Since we want to kill this code in favor of + -- new-build, I decided it wasn't worth fixing this "properly." + -- Also, this doesn't handle LHC correctly but I don't care -- ezyang + let extraLibPath = + case buildOS of + Windows -> sandboxDir + _ -> sandboxDir "lib" + -- 2016-11-26 Apologies for the spaghetti code here. + -- Essentially we just want to add the sandbox's lib/ dir to + -- whatever the library search path environment variable is: + -- this allows running existing executables against foreign + -- libraries (meaning Haskell code with a bunch of foreign + -- exports). However, on Windows this variable is equal to the + -- executable search path env var. And we try to keep not only + -- what was already set in the environment, but also the + -- additional directories we add below in requireProgram'. So + -- the strategy is that we first take the environment + -- overrides from requireProgram' below. If the library search + -- path env is overridden (e.g. because we're on windows), we + -- prepend the lib/ dir to the relevant override. If not, we + -- want to avoid wiping the user's own settings, so we first + -- read the env var's current value, and then prefix ours if + -- the user had any set. + iEnv' <- + if any ((==ldPath) . fst) iEnv + then return $ updateLdPath extraLibPath iEnv + else do + currentLibraryPath <- lookupEnv ldPath + let updatedLdPath = + case currentLibraryPath of + Nothing -> Just extraLibPath + Just paths -> + Just $ extraLibPath ++ [searchPathSeparator] ++ paths + return $ (ldPath, updatedLdPath) : iEnv + -- Build the environment - return [ (packagePathEnvVar, Just compilerPackagePaths) - , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths) - , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) - ] + return $ [ (packagePathEnvVar, Just compilerPackagePaths) + , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths) + , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) + ] ++ iEnv' prependToSearchPath path newValue = newValue ++ [searchPathSeparator] ++ path + + updateLdPath path = map update + where + update (name, Just current) + | name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current) + update (name, Nothing) + | name == ldPath = (ldPath, Just path) + update x = x -- | Check that a program is configured and available to be run. If diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -21,23 +21,25 @@ import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage + import Distribution.Package ( packageId ) import Distribution.Simple.Compiler ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program - ( ProgramConfiguration ) + ( ProgramDb ) import Distribution.Simple.Setup ( fromFlag ) import Distribution.Simple.Utils - ( die, notice, debug ) + ( die', notice, debug ) import Distribution.System ( Platform ) import Distribution.Text @@ -69,7 +71,7 @@ -> RepoContext -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> GlobalFlags -> FetchFlags -> [UserTarget] @@ -77,14 +79,14 @@ fetch verbosity _ _ _ _ _ _ _ [] = notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repoCtxt comp platform conf +fetch verbosity packageDBs repoCtxt comp platform progdb globalFlags fetchFlags userTargets = do - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity conf + pkgConfigDb <- readPkgConfigDb verbosity progdb pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) @@ -120,8 +122,8 @@ -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb - -> [PackageSpecifier SourcePackage] - -> IO [SourcePackage] + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [UnresolvedSourcePackage] planPackages verbosity comp platform fetchFlags installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers @@ -129,7 +131,7 @@ solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver @@ -138,12 +140,12 @@ -- The packages we want to fetch are those packages the 'InstallPlan' -- that are in the 'InstallPlan.Configured' state. return - [ pkg - | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _)) - <- InstallPlan.toList installPlan ] + [ solverPkgSource cpkg + | (SolverInstallPlan.Configured cpkg) + <- SolverInstallPlan.toList installPlan ] | otherwise = - either (die . unlines . map show) return $ + either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies resolverParams where @@ -156,10 +158,16 @@ . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setShadowPkgs shadowPkgs . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + -- Reinstall the targets given on the command line so that the dep -- resolver will decide that they need fetching, even if they're -- already installed. Since we want to get the source packages of @@ -172,16 +180,18 @@ logMsg message rest = debug verbosity message >> rest reorderGoals = fromFlag (fetchReorderGoals fetchFlags) + countConflicts = fromFlag (fetchCountConflicts fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) + allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of UserTargetRemoteTarball _uri - -> die $ "The 'fetch' command does not yet support remote tarballs. " + -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." _ -> return () @@ -191,7 +201,7 @@ LocalTarballPackage _file -> return () RemoteTarballPackage _uri _ -> - die $ "The 'fetch' command does not yet support remote tarballs. " + die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." RepoTarballPackage repo pkgid _ -> do diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -23,6 +23,11 @@ checkRepoTarballFetched, fetchRepoTarball, + -- ** fetching packages asynchronously + asyncFetchPackages, + waitAsyncFetchPackage, + AsyncFetchMap, + -- * fetching other things downloadIndex, ) where @@ -35,15 +40,21 @@ import Distribution.Package ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils - ( notice, info, setupMessage ) + ( notice, info, debug, setupMessage ) import Distribution.Text ( display ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity, verboseUnmarkOutput ) import Distribution.Client.GlobalFlags ( RepoContext(..) ) import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad +import Control.Exception +import Control.Concurrent.Async +import Control.Concurrent.MVar import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.IO @@ -64,20 +75,19 @@ -- | Returns @True@ if the package has already been fetched -- or does not need fetching. -- -isFetched :: PackageLocation (Maybe FilePath) -> IO Bool +isFetched :: UnresolvedPkgLoc -> IO Bool isFetched loc = case loc of LocalUnpackedPackage _dir -> return True LocalTarballPackage _file -> return True RemoteTarballPackage _uri local -> return (isJust local) RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) - -- | Checks if the package has already been fetched (or does not need -- fetching) and if so returns evidence in the form of a 'PackageLocation' -- with a resolved local file location. -- -checkFetched :: PackageLocation (Maybe FilePath) - -> IO (Maybe (PackageLocation FilePath)) +checkFetched :: UnresolvedPkgLoc + -> IO (Maybe ResolvedPkgLoc) checkFetched loc = case loc of LocalUnpackedPackage dir -> return (Just $ LocalUnpackedPackage dir) @@ -109,8 +119,8 @@ -- fetchPackage :: Verbosity -> RepoContext - -> PackageLocation (Maybe FilePath) - -> IO (PackageLocation FilePath) + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc fetchPackage verbosity repoCtxt loc = case loc of LocalUnpackedPackage dir -> return (LocalUnpackedPackage dir) @@ -130,7 +140,7 @@ where downloadTarballPackage uri = do transport <- repoContextGetTransport repoCtxt - transportCheckHttps transport uri + transportCheckHttps verbosity transport uri notice verbosity ("Downloading " ++ show uri) tmpdir <- getTemporaryDirectory (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" @@ -155,7 +165,7 @@ RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt - remoteRepoCheckHttps transport repoRemote + remoteRepoCheckHttps verbosity transport repoRemote let uri = packageURI repoRemote pkgid dir = packageDir repo pkgid path = packageFile repo pkgid @@ -172,11 +182,13 @@ Sec.downloadPackage' rep pkgid path return path --- | Downloads an index file to [config-dir/packages/serv-id]. +-- | Downloads an index file to [config-dir/packages/serv-id] without +-- hackage-security. You probably don't want to call this directly; +-- use 'updateRepo' instead. -- downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex transport verbosity remoteRepo cacheDir = do - remoteRepoCheckHttps transport remoteRepo + remoteRepoCheckHttps verbosity transport remoteRepo let uri = (remoteRepoURI remoteRepo) { uriPath = uriPath (remoteRepoURI remoteRepo) `FilePath.Posix.combine` "00-index.tar.gz" @@ -184,6 +196,69 @@ path = cacheDir "00-index" <.> "tar.gz" createDirectoryIfMissing True cacheDir downloadURI transport verbosity uri path + + +-- ------------------------------------------------------------ +-- * Async fetch wrapper utilities +-- ------------------------------------------------------------ + +type AsyncFetchMap = Map UnresolvedPkgLoc + (MVar (Either SomeException ResolvedPkgLoc)) + +-- | Fork off an async action to download the given packages (by location). +-- +-- The downloads are initiated in order, so you can arrange for packages that +-- will likely be needed sooner to be earlier in the list. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'asyncFetchPackage' to get the result. +-- +asyncFetchPackages :: Verbosity + -> RepoContext + -> [UnresolvedPkgLoc] + -> (AsyncFetchMap -> IO a) + -> IO a +asyncFetchPackages verbosity repoCtxt pkglocs body = do + --TODO: [nice to have] use parallel downloads? + + asyncDownloadVars <- sequence [ do v <- newEmptyMVar + return (pkgloc, v) + | pkgloc <- pkglocs ] + + let fetchPackages :: IO () + fetchPackages = + forM_ asyncDownloadVars $ \(pkgloc, var) -> do + -- Suppress marking here, because 'withAsync' means + -- that we get nondeterministic interleaving + result <- try $ fetchPackage (verboseUnmarkOutput verbosity) + repoCtxt pkgloc + putMVar var result + + withAsync fetchPackages $ \_ -> + body (Map.fromList asyncDownloadVars) + + +-- | Expect to find a download in progress in the given 'AsyncFetchMap' +-- and wait on it to finish. +-- +-- If the download failed with an exception then this will be thrown. +-- +-- Note: This function is supposed to be idempotent, as our install plans +-- can now use the same tarball for many builds, e.g. different +-- components and/or qualified goals, and these all go through the +-- download phase so we end up using 'waitAsyncFetchPackage' twice on +-- the same package. C.f. #4461. +waitAsyncFetchPackage :: Verbosity + -> AsyncFetchMap + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +waitAsyncFetchPackage verbosity downloadMap srcloc = + case Map.lookup srcloc downloadMap of + Just hnd -> do + debug verbosity $ "Waiting for download of " ++ show srcloc + either throwIO return =<< readMVar hnd + Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" -- ------------------------------------------------------------ diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs --- a/Distribution/Client/FileMonitor.hs +++ b/Distribution/Client/FileMonitor.hs @@ -15,6 +15,7 @@ monitorFile, monitorFileHashed, monitorNonExistentFile, + monitorFileExistence, monitorDirectory, monitorNonExistentDirectory, monitorDirectoryExistence, @@ -35,23 +36,18 @@ beginUpdateFileMonitor, ) where +import Prelude () +import Distribution.Client.Compat.Prelude #if MIN_VERSION_containers(0,5,0) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map #else -import Data.Map (Map) import qualified Data.Map as Map #endif import qualified Data.ByteString.Lazy as BS -import Distribution.Compat.Binary import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable -import Data.List (sort) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Monad import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.State (StateT, mapStateT) @@ -60,7 +56,7 @@ throwError) import Control.Exception -import Distribution.Client.Compat.Time +import Distribution.Compat.Time import Distribution.Client.Glob import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Client.Utils (mergeBy, MergeResult(..)) @@ -68,9 +64,7 @@ import System.FilePath import System.Directory import System.IO -import GHC.Generics (Generic) - ------------------------------------------------------------------------------ -- Types for specifying files to monitor -- @@ -130,6 +124,12 @@ monitorNonExistentFile :: FilePath -> MonitorFilePath monitorNonExistentFile = MonitorFile FileNotExists DirNotExists +-- | Monitor a single file for existence only. The monitored file is +-- considered to have changed if it no longer exists. +-- +monitorFileExistence :: FilePath -> MonitorFilePath +monitorFileExistence = MonitorFile FileExists DirNotExists + -- | Monitor a single directory for changes, based on its modification -- time. The monitored directory is considered to have changed if it no -- longer exists or if its modification time has changed. @@ -199,8 +199,13 @@ -- files to be monitored (index by their path), and a list of -- globs, which monitor may files at once. data MonitorStateFileSet - = MonitorStateFileSet !(Map FilePath MonitorStateFile) + = MonitorStateFileSet ![MonitorStateFile] ![MonitorStateGlob] + -- Morally this is not actually a set but a bag (represented by lists). + -- There is no principled reason to use a bag here rather than a set, but + -- there is also no particular gain either. That said, we do preserve the + -- order of the lists just to reduce confusion (and have predictable I/O + -- patterns). deriving Show type Hash = Int @@ -216,7 +221,7 @@ -- no longer exists at all. -- data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir - !MonitorStateFileStatus + !FilePath !MonitorStateFileStatus deriving (Show, Generic) data MonitorStateFileStatus @@ -262,11 +267,10 @@ -- reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - Map.foldrWithKey (\k x r -> getSinglePath k x : r) - (map getGlobPath globPaths) - singlePaths + map getSinglePath singlePaths + ++ map getGlobPath globPaths where - getSinglePath filepath (MonitorStateFile kindfile kinddir _) = + getSinglePath (MonitorStateFile kindfile kinddir filepath _) = MonitorFile kindfile kinddir filepath getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = @@ -516,7 +520,7 @@ runChangedM $ do sequence_ [ probeMonitorStateFileStatus root file status - | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ] + | MonitorStateFile _ _ file status <- singlePaths ] -- The glob monitors can require state changes globPaths' <- sequence @@ -793,19 +797,19 @@ -- relative to root -> IO MonitorStateFileSet buildMonitorStateFileSet mstartTime hashcache root = - go Map.empty [] + go [] [] where - go :: Map FilePath MonitorStateFile -> [MonitorStateGlob] + go :: [MonitorStateFile] -> [MonitorStateGlob] -> [MonitorFilePath] -> IO MonitorStateFileSet go !singlePaths !globPaths [] = - return (MonitorStateFileSet singlePaths globPaths) + return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) go !singlePaths !globPaths (MonitorFile kindfile kinddir path : monitors) = do - monitorState <- MonitorStateFile kindfile kinddir + monitorState <- MonitorStateFile kindfile kinddir path <$> buildMonitorStateFile mstartTime hashcache kindfile kinddir root path - go (Map.insert path monitorState singlePaths) globPaths monitors + go (monitorState : singlePaths) globPaths monitors go !singlePaths !globPaths (MonitorFileGlob kindfile kinddir globPath : monitors) = do @@ -976,15 +980,15 @@ collectAllFileHashes singlePaths `Map.union` collectAllGlobHashes globPaths - collectAllFileHashes = - Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of - MonitorStateFileHashed mtime hash -> Just (mtime, hash) - _ -> Nothing + collectAllFileHashes singlePaths = + Map.fromList [ (fpath, (mtime, hash)) + | MonitorStateFile _ _ fpath + (MonitorStateFileHashed mtime hash) <- singlePaths ] collectAllGlobHashes globPaths = - Map.fromList [ (fpath, hash) + Map.fromList [ (fpath, (mtime, hash)) | MonitorStateGlob _ _ _ gstate <- globPaths - , (fpath, hash) <- collectGlobHashes "" gstate ] + , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ] collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = [ res diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs --- a/Distribution/Client/Freeze.hs +++ b/Distribution/Client/Freeze.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Freeze @@ -16,19 +15,18 @@ freeze, getFreezePkgs ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types - ( ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) -import Distribution.Client.InstallPlan - ( InstallPlan, PlanPackage ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan, SolverPlanPackage ) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Setup ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) , RepoContext(..) ) @@ -38,17 +36,23 @@ import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.SolverId + import Distribution.Package ( Package, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program - ( ProgramConfiguration ) + ( ProgramDb ) import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( die, notice, debug, writeFileAtomic ) + ( die', notice, debug, writeFileAtomic ) import Distribution.System ( Platform ) import Distribution.Text @@ -56,15 +60,7 @@ import Distribution.Verbosity ( Verbosity ) -import Control.Monad - ( when ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( mempty ) -#endif -import Data.Version - ( showVersion ) import Distribution.Version ( thisVersion ) @@ -76,20 +72,20 @@ -- constraining each dependency to an exact version. -- freeze :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramConfiguration - -> Maybe SandboxPackageInfo - -> GlobalFlags - -> FreezeFlags - -> IO () -freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> Maybe SandboxPackageInfo + -> GlobalFlags + -> FreezeFlags + -> IO () +freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo + verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags if null pkgs @@ -112,17 +108,17 @@ -> RepoContext -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> Maybe SandboxPackageInfo -> GlobalFlags -> FreezeFlags - -> IO [PlanPackage] -getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo + -> IO [SolverPlanPackage] +getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity conf + pkgConfigDb <- readPkgConfigDb verbosity progdb pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) @@ -136,10 +132,10 @@ where sanityCheck pkgSpecifiers = do when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected named package specifiers!" when (length pkgSpecifiers /= 1) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected source package specifiers!" planPackages :: Verbosity @@ -150,8 +146,8 @@ -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb - -> [PackageSpecifier SourcePackage] - -> IO [PlanPackage] + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO [SolverPlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do @@ -159,7 +155,7 @@ (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver @@ -177,13 +173,20 @@ . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setShadowPkgs shadowPkgs . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraintStanzas pkg stanzas + pc = PackageConstraint (scopeToplevel pkg) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] @@ -199,10 +202,12 @@ benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags reorderGoals = fromFlag (freezeReorderGoals freezeFlags) + countConflicts = fromFlag (freezeCountConflicts freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) strongFlags = fromFlag (freezeStrongFlags freezeFlags) maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) + allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) -- | Remove all unneeded packages from an install plan. @@ -214,14 +219,17 @@ -- 2) not a dependency (directly or transitively) of the package we are -- freezing. This is useful for removing previously installed packages -- which are no longer required from the install plan. -pruneInstallPlan :: InstallPlan - -> [PackageSpecifier SourcePackage] - -> [PlanPackage] +-- +-- Invariant: @pkgSpecifiers@ must refer to packages which are not +-- 'PreExisting' in the 'SolverInstallPlan'. +pruneInstallPlan :: SolverInstallPlan + -> [PackageSpecifier UnresolvedSourcePackage] + -> [SolverPlanPackage] pruneInstallPlan installPlan pkgSpecifiers = removeSelf pkgIds $ - InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds) + SolverInstallPlan.dependencyClosure installPlan pkgIds where - pkgIds = [ packageId pkg + pkgIds = [ PlannedId (packageId pkg) | SpecificSourcePackage pkg <- pkgSpecifiers ] removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) removeSelf _ = error $ "internal error: 'pruneInstallPlan' given " @@ -232,7 +240,8 @@ freezePackages verbosity globalFlags pkgs = do pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ - loadUserConfig verbosity "" (flagToMaybe . globalConstraintsFile $ globalFlags) + loadUserConfig verbosity "" + (flagToMaybe . globalConstraintsFile $ globalFlags) writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv where addFrozenConstraints config = @@ -242,11 +251,12 @@ } } constraint pkg = - (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile) + (pkgIdToConstraint $ packageId pkg + ,ConstraintSourceUserConfig userPackageEnvironmentFile) where pkgIdToConstraint pkgId = - UserConstraintVersion (packageName pkgId) - (thisVersion $ packageVersion pkgId) + UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) createPkgEnv config = mempty { pkgEnvSavedConfig = config } showPkgEnv = BS.Char8.pack . showPackageEnvironment @@ -256,4 +266,4 @@ where showPkg pid = name pid ++ " == " ++ version pid name = display . packageName - version = showVersion . packageVersion + version = display . packageVersion diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.GenBounds @@ -14,8 +15,6 @@ genBounds ) where -import Data.Version - ( Version(..), showVersion ) import Distribution.Client.Init ( incVersion ) import Distribution.Client.Freeze @@ -25,26 +24,36 @@ import Distribution.Client.Setup ( GlobalFlags(..), FreezeFlags(..), RepoContext ) import Distribution.Package - ( Package(..), Dependency(..), PackageName(..) - , packageName, packageVersion ) + ( Package(..), unPackageName, packageName, packageVersion ) import Distribution.PackageDescription ( buildDepends ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) + ( finalizePD ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +#else import Distribution.PackageDescription.Parse - ( readPackageDescription ) + ( readGenericPackageDescription ) +#endif +import Distribution.Types.ComponentRequestedSpec + ( defaultComponentRequestedSpec ) +import Distribution.Types.Dependency import Distribution.Simple.Compiler ( Compiler, PackageDBStack, compilerInfo ) import Distribution.Simple.Program - ( ProgramConfiguration ) + ( ProgramDb ) import Distribution.Simple.Utils ( tryFindPackageDesc ) import Distribution.System ( Platform ) +import Distribution.Text + ( display ) import Distribution.Verbosity ( Verbosity ) import Distribution.Version - ( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals + ( Version, alterVersion + , LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals , orLaterVersion, earlierVersion, intersectVersionRanges ) import System.Directory ( getCurrentDirectory ) @@ -69,7 +78,7 @@ `intersectVersionRanges` earlierVersion (incVersion 1 (vn 2)) where - vn n = (v { versionBranch = take n (versionBranch v) }) + vn n = alterVersion (take n) v -- | Show the PVP-mandated version range for this package. The @padTo@ parameter -- specifies the width of the package name column. @@ -85,7 +94,7 @@ showInterval (LowerBound _ _, NoUpperBound) = error "Error: expected upper bound...this should never happen!" showInterval (LowerBound l _, UpperBound u _) = - unwords [">=", showVersion l, "&& <", showVersion u] + unwords [">=", display l, "&& <", display u] -- | Entry point for the @gen-bounds@ command. genBounds @@ -94,22 +103,25 @@ -> RepoContext -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> Maybe SandboxPackageInfo -> GlobalFlags -> FreezeFlags -> IO () -genBounds verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo +genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do let cinfo = compilerInfo comp cwd <- getCurrentDirectory path <- tryFindPackageDesc cwd - gpd <- readPackageDescription verbosity path - let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd + gpd <- readGenericPackageDescription verbosity path + -- NB: We don't enable tests or benchmarks, since often they + -- don't really have useful bounds. + let epd = finalizePD [] defaultComponentRequestedSpec + (const True) platform cinfo [] gpd case epd of - Left _ -> putStrLn "finalizePackageDescription failed" + Left _ -> putStrLn "finalizePD failed" Right (pd,_) -> do let needBounds = filter (not . hasUpperBound . depVersion) $ buildDepends pd @@ -121,7 +133,7 @@ where go needBounds = do pkgs <- getFreezePkgs - verbosity packageDBs repoCtxt comp platform conf + verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags putStrLn boundsNeededMsg @@ -134,7 +146,7 @@ mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs depName :: Dependency -> String - depName (Dependency (PackageName nm) _) = nm + depName (Dependency pn _) = unPackageName pn depVersion :: Dependency -> VersionRange depVersion (Dependency _ vr) = vr diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Get @@ -18,12 +17,15 @@ get ) where +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + import Distribution.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils - ( notice, die, info, writeFileAtomic ) + ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display) @@ -37,25 +39,19 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages ) + ( getSourcePackagesAtIndexState, IndexState(..) ) import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import Distribution.Compat.Exception ( catchIO ) +import Distribution.Solver.Types.SourcePackage + import Control.Exception ( finally ) import Control.Monad - ( filterM, forM_, unless, when ) -import Data.List - ( sortBy ) + ( forM_, mapM_ ) import qualified Data.Map -import Data.Maybe - ( listToMaybe, mapMaybe ) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( mempty ) -#endif import Data.Ord ( comparing ) import System.Directory @@ -66,8 +62,6 @@ ( ExitCode(..) ) import System.FilePath ( (), (<.>), addTrailingPathSeparator ) -import System.Process - ( rawSystem ) -- | Entry point for the 'cabal get' command. @@ -86,16 +80,19 @@ _ -> True unless useFork $ - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets - sourcePkgDb <- getSourcePackages verbosity repoCtxt + let idxState = fromFlagOrDefault IndexStateHead $ + getIndexState getFlags + sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) (packageIndex sourcePkgDb) userTargets - pkgs <- either (die . unlines . map show) return $ + pkgs <- either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) @@ -113,13 +110,13 @@ prefix = fromFlagOrDefault "" (getDestDir getFlags) - fork :: [SourcePackage] -> IO () + fork :: [UnresolvedSourcePackage] -> IO () fork pkgs = do let kind = fromFlag . getSourceRepository $ getFlags branchers <- findUsableBranchers mapM_ (forkPackage verbosity branchers prefix kind) pkgs - unpack :: [SourcePackage] -> IO () + unpack :: [UnresolvedSourcePackage] -> IO () unpack pkgs = do forM_ pkgs $ \pkg -> do location <- fetchPackage verbosity repoCtxt (packageSource pkg) @@ -141,10 +138,10 @@ where usePristine = fromFlagOrDefault False (getPristine getFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of - UserTargetLocalDir dir -> die (notTarball dir) - UserTargetLocalCabalFile file -> die (notTarball file) +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) _ -> return () where notTarball t = @@ -163,10 +160,10 @@ pkgdir = prefix pkgdirname pkgdir' = addTrailingPathSeparator pkgdir existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ + when existsDir $ die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." existsFile <- doesFileExist pkgdir - when existsFile $ die $ + when existsFile $ die' verbosity $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath @@ -226,7 +223,7 @@ -- be created. -> (Maybe PD.RepoKind) -- ^ Which repo to choose. - -> SourcePackage + -> SourcePackage loc -- ^ The package to fork. -> IO () forkPackage verbosity branchers prefix kind src = do @@ -237,11 +234,11 @@ destDirExists <- doesDirectoryExist destdir when destDirExists $ do - die ("The directory " ++ show destdir ++ " already exists, not forking.") + die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.") destFileExists <- doesFileExist destdir when destFileExists $ do - die ("A file " ++ show destdir ++ " is in the way, not forking.") + die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.") let repos = PD.sourceRepos desc case findBranchCmd branchers repos kind of @@ -249,11 +246,11 @@ exitCode <- io verbosity destdir case exitCode of ExitSuccess -> return () - ExitFailure _ -> die ("Couldn't fork package " ++ pkgid) + ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid) Nothing -> case repos of - [] -> die ("Package " ++ pkgid + [] -> die' verbosity ("Package " ++ pkgid ++ " does not have any source repositories.") - _ -> die ("Package " ++ pkgid + _ -> die' verbosity ("Package " ++ pkgid ++ " does not have any usable source repositories.") -- | Given a set of possible branchers, and a set of possible source @@ -295,7 +292,7 @@ Nothing -> ["branch", src, dst] return $ BranchCmd $ \verbosity dst -> do notice verbosity ("bzr: branch " ++ show src) - rawSystem "bzr" (args dst) + rawSystemExitCode verbosity "bzr" (args dst) -- | Branch driver for Darcs. branchDarcs :: Brancher @@ -306,29 +303,29 @@ Nothing -> ["get", src, dst] return $ BranchCmd $ \verbosity dst -> do notice verbosity ("darcs: get " ++ show src) - rawSystem "darcs" (args dst) + rawSystemExitCode verbosity "darcs" (args dst) -- | Branch driver for Git. branchGit :: Brancher branchGit = Brancher "git" $ \repo -> do src <- PD.repoLocation repo - let branchArgs = case PD.repoBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - let postClone dst = case PD.repoTag repo of + let postClone verbosity dst = case PD.repoTag repo of Just t -> do cwd <- getCurrentDirectory setCurrentDirectory dst finally - (rawSystem "git" (["checkout", t] ++ branchArgs)) + (rawSystemExitCode verbosity "git" ["checkout", t]) (setCurrentDirectory cwd) Nothing -> return ExitSuccess return $ BranchCmd $ \verbosity dst -> do notice verbosity ("git: clone " ++ show src) - code <- rawSystem "git" (["clone", src, dst] ++ branchArgs) + code <- rawSystemExitCode verbosity "git" (["clone", src, dst] ++ + case PD.repoBranch repo of + Nothing -> [] + Just b -> ["--branch", b]) case code of ExitFailure _ -> return code - ExitSuccess -> postClone dst + ExitSuccess -> postClone verbosity dst -- | Branch driver for Mercurial. branchHg :: Brancher @@ -343,7 +340,7 @@ let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs return $ BranchCmd $ \verbosity dst -> do notice verbosity ("hg: clone " ++ show src) - rawSystem "hg" (args dst) + rawSystemExitCode verbosity "hg" (args dst) -- | Branch driver for Subversion. branchSvn :: Brancher @@ -352,4 +349,4 @@ let args dst = ["checkout", src, dst] return $ BranchCmd $ \verbosity dst -> do notice verbosity ("svn: checkout " ++ show src) - rawSystem "svn" (args dst) + rawSystemExitCode verbosity "svn" (args dst) diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs --- a/Distribution/Client/Glob.hs +++ b/Distribution/Client/Glob.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} --TODO: [code cleanup] plausibly much of this module should be merged with -- similar functionality in Cabal. @@ -15,14 +15,11 @@ , getFilePathRootDirectory ) where -import Data.Char (toUpper) +import Prelude () +import Distribution.Client.Compat.Prelude + import Data.List (stripPrefix) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad -import Distribution.Compat.Binary -import GHC.Generics (Generic) +import Control.Monad (mapM) import Distribution.Text import Distribution.Compat.ReadP (ReadP, (<++), (+++)) diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs --- a/Distribution/Client/GlobalFlags.hs +++ b/Distribution/Client/GlobalFlags.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} + module Distribution.Client.GlobalFlags ( GlobalFlags(..) , defaultGlobalFlags @@ -12,9 +13,11 @@ , withRepoContext' ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Types ( Repo(..), RemoteRepo(..) ) -import Distribution.Compat.Semigroup import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -26,22 +29,15 @@ import Distribution.Simple.Utils ( info ) -import Data.Maybe - ( fromMaybe ) import Control.Concurrent ( MVar, newMVar, modifyMVar ) import Control.Exception ( throwIO ) -import Control.Monad - ( when ) import System.FilePath ( () ) import Network.URI - ( uriScheme, uriPath ) -import Data.Map - ( Map ) + ( URI, uriScheme, uriPath ) import qualified Data.Map as Map -import GHC.Generics ( Generic ) import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Path as Sec @@ -50,6 +46,7 @@ import qualified Hackage.Security.Client.Repository.Local as Sec.Local import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote import qualified Distribution.Client.Security.HTTP as Sec.HTTP +import qualified Distribution.Client.Security.DNS as Sec.DNS -- ------------------------------------------------------------ -- * Global flags @@ -70,7 +67,8 @@ globalRequireSandbox :: Flag Bool, globalIgnoreSandbox :: Flag Bool, globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates - globalHttpTransport :: Flag String + globalHttpTransport :: Flag String, + globalNix :: Flag Bool -- ^ Integrate with Nix } deriving Generic defaultGlobalFlags :: GlobalFlags @@ -88,7 +86,8 @@ globalRequireSandbox = Flag False, globalIgnoreSandbox = Flag False, globalIgnoreExpiry = Flag False, - globalHttpTransport = mempty + globalHttpTransport = mempty, + globalNix = Flag False } instance Monoid GlobalFlags where @@ -219,8 +218,19 @@ -> (SecureRepo -> IO a) -- ^ Callback -> IO a initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do - withRepo $ \r -> do - requiresBootstrap <- Sec.requiresBootstrap r + requiresBootstrap <- withRepo [] Sec.requiresBootstrap + + mirrors <- if requiresBootstrap + then do + info verbosity $ "Trying to locate mirrors via DNS for " ++ + "initial bootstrap of secure " ++ + "repository '" ++ show remoteRepoURI ++ + "' ..." + + Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI + else pure [] + + withRepo mirrors $ \r -> do when requiresBootstrap $ Sec.uncheckClientErrors $ Sec.bootstrap r (map Sec.KeyId remoteRepoRootKeys) @@ -228,8 +238,8 @@ callback $ SecureRepo r where -- Initialize local or remote repo depending on the URI - withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a - withRepo callback | uriScheme remoteRepoURI == "file:" = do + withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a + withRepo _ callback | uriScheme remoteRepoURI == "file:" = do dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI) Sec.Local.withRepository dir cache @@ -237,9 +247,9 @@ Sec.hackageIndexLayout logTUF callback - withRepo callback = + withRepo mirrors callback = Sec.Remote.withRepository httpLib - [remoteRepoURI] + (remoteRepoURI:mirrors) Sec.Remote.defaultRepoOpts cache Sec.hackageRepoLayout diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -23,9 +23,9 @@ import Distribution.Package ( packageVersion ) import Distribution.Simple.Haddock (haddockPackagePaths) -import Distribution.Simple.Program (haddockProgram, ProgramConfiguration - , rawSystemProgram, requireProgramVersion) -import Distribution.Version (Version(Version), orLaterVersion) +import Distribution.Simple.Program (haddockProgram, ProgramDb + , runProgram, requireProgramVersion) +import Distribution.Version (mkVersion, orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, allPackagesByName ) @@ -35,17 +35,17 @@ ( InstalledPackageInfo(exposed) ) regenerateHaddockIndex :: Verbosity - -> InstalledPackageIndex -> ProgramConfiguration + -> InstalledPackageIndex -> ProgramDb -> FilePath -> IO () -regenerateHaddockIndex verbosity pkgs conf index = do +regenerateHaddockIndex verbosity pkgs progdb index = do (paths, warns) <- haddockPackagePaths pkgs' Nothing let paths' = [ (interface, html) | (interface, Just html) <- paths] forM_ warns (debug verbosity) (confHaddock, _, _) <- requireProgramVersion verbosity haddockProgram - (orLaterVersion (Version [0,6] [])) conf + (orLaterVersion (mkVersion [0,6])) progdb createDirectoryIfMissing True destDir @@ -57,7 +57,7 @@ , "--title=Haskell modules on this system" ] ++ [ "--read-interface=" ++ html ++ "," ++ interface | (interface, html) <- paths' ] - rawSystemProgram verbosity confHaddock flags + runProgram verbosity confHaddock flags renameFile (tempDir "index.html") (tempDir destFile) installDirectoryContents verbosity tempDir destDir diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | Separate module for HTTP actions, using a proxy server if one exists. ----------------------------------------------------------------------------- @@ -14,6 +14,9 @@ isOldHackageURI ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Network.HTTP ( Request (..), Response (..), RequestMethod (..) , Header(..), HeaderName(..), lookupHeader ) @@ -23,39 +26,36 @@ import Network.Browser ( browse, setOutHandler, setErrHandler, setProxy , setAuthorityGen, request, setAllowBasicAuth, setUserAgent ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import qualified Control.Exception as Exception +import Control.Exception + ( evaluate ) +import Control.DeepSeq + ( force ) import Control.Monad - ( when, guard ) + ( guard ) import qualified Data.ByteString.Lazy.Char8 as BS -import Data.List - ( isPrefixOf, find, intercalate ) -import Data.Maybe - ( listToMaybe, maybeToList, fromMaybe ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, info, warn, debug, notice, writeFileAtomic + ( die', info, warn, debug, notice, writeFileAtomic , copyFileVerbose, withTempFile , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Client.Utils - ( readMaybe, withTempFileName ) + ( withTempFileName ) import Distribution.Client.Types ( RemoteRepo(..) ) import Distribution.System ( buildOS, buildArch ) import Distribution.Text ( display ) -import Data.Char - ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) import System.FilePath ( (<.>) ) import System.Directory ( doesFileExist, renameFile ) +import System.IO + ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error ( isDoesNotExistError ) import Distribution.Simple.Program @@ -70,7 +70,6 @@ ( IOEncoding(..), getEffectiveEnvironment ) import Numeric (showHex) import System.Directory (canonicalizePath) -import System.IO (hClose) import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..)) @@ -132,26 +131,26 @@ 304 -> do notice verbosity "Skipping download: local and remote files match." return FileAlreadyInCache - errCode -> die $ "Failed to download " ++ show uri + errCode -> die' verbosity $ "Failed to download " ++ show uri ++ " : HTTP code " ++ show errCode ------------------------------------------------------------------------------ -- Utilities for repo url management -- -remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps transport repo +remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps verbosity transport repo | uriScheme (remoteRepoURI repo) == "https:" , not (transportSupportsHttps transport) - = die $ "The remote repository '" ++ remoteRepoName repo + = die' verbosity $ "The remote repository '" ++ remoteRepoName repo ++ "' specifies a URL that " ++ requiresHttpsErrorMessage | otherwise = return () -transportCheckHttps :: HttpTransport -> URI -> IO () -transportCheckHttps transport uri +transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () +transportCheckHttps verbosity transport uri | uriScheme uri == "https:" , not (transportSupportsHttps transport) - = die $ "The URL " ++ show uri + = die' verbosity $ "The URL " ++ show uri ++ " " ++ requiresHttpsErrorMessage | otherwise = return () @@ -165,13 +164,13 @@ ++ "external program is available, or one can be selected specifically " ++ "with the global flag --http-transport=" -remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo -remoteRepoTryUpgradeToHttps transport repo +remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps verbosity transport repo | remoteRepoShouldTryHttps repo , uriScheme (remoteRepoURI repo) == "http:" , not (transportSupportsHttps transport) , not (transportManuallySelected transport) - = die $ "The builtin HTTP implementation does not support HTTPS, but using " + = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " ++ "HTTPS for authenticated uploads is recommended. " ++ "The transport implementations with HTTPS support are " ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] @@ -247,7 +246,7 @@ noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) -> IO (Int, String) -noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet" +noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" supportedTransports :: [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)] @@ -285,7 +284,7 @@ let Just transport = mkTrans progdb return transport { transportManuallySelected = True } - Nothing -> die $ "Unknown HTTP transport specified: " ++ name + Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name ++ ". The supported transports are " ++ intercalate ", " [ name' | (name', _, _, _ ) <- supportedTransports ] @@ -340,9 +339,10 @@ resp <- getProgramInvocationOutput verbosity (programInvocation prog args) - headers <- readFile tmpFile - (code, _err, etag') <- parseResponse uri resp headers - return (code, etag') + withFile tmpFile ReadMode $ \hnd -> do + headers <- hGetContents hnd + (code, _err, etag') <- parseResponse verbosity uri resp headers + evaluate $ force (code, etag') posthttp = noPostYet @@ -367,7 +367,7 @@ ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) puthttpfile verbosity uri path auth headers = do @@ -384,12 +384,13 @@ | Header name value <- headers ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) - -- on success these curl involcations produces an output like "200" + -- on success these curl invocations produces an output like "200" -- and on failure it has the server error response first - parseResponse uri resp headers = + parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) + parseResponse verbosity uri resp headers = let codeerr = case reverse (lines resp) of (codeLine:rerrLines) -> @@ -408,16 +409,29 @@ in case codeerr of Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp wgetTransport :: ConfiguredProgram -> HttpTransport wgetTransport prog = - HttpTransport gethttp posthttp posthttpfile puthttpfile True False + HttpTransport gethttp posthttp posthttpfile puthttpfile True False where - gethttp verbosity uri etag destPath reqHeaders = do + gethttp verbosity uri etag destPath reqHeaders = do resp <- runWGet verbosity uri args - (code, etag') <- parseOutput uri resp + + -- wget doesn't support range requests. + -- so, we not only ignore range request headers, + -- but we also dispay a warning message when we see them. + let hasRangeHeader = any (\hdr -> isRangeHeader hdr) reqHeaders + warningMsg = "the 'wget' transport currently doesn't support" + ++ " range requests, which wastes network bandwidth." + ++ " To fix this, set 'http-transport' to 'curl' or" + ++ " 'plain-http' in '~/.cabal/config'." + ++ " Note that the 'plain-http' transport doesn't" + ++ " support HTTPS.\n" + + when (hasRangeHeader) $ warn verbosity warningMsg + (code, etag') <- parseOutput verbosity uri resp return (code, etag') where args = [ "--output-document=" ++ destPath @@ -429,14 +443,22 @@ [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] ++ [ "--header=" ++ show name ++ ": " ++ value - | Header name value <- reqHeaders ] + | hdr@(Header name value) <- reqHeaders + , (not (isRangeHeader hdr)) ] + -- wget doesn't support range requests. + -- so, we ignore range request headers, lest we get errors. + isRangeHeader :: Header -> Bool + isRangeHeader (Header HdrRange _) = True + isRangeHeader _ = False + posthttp = noPostYet posthttpfile verbosity uri path auth = withTempFile (takeDirectory path) (takeFileName path) $ \tmpFile tmpHandle -> - withTempFile (takeDirectory path) "response" $ \responseFile responseHandle -> do + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do hClose responseHandle (body, boundary) <- generateMultipartBody path BS.hPut tmpHandle body @@ -449,12 +471,14 @@ , "--header=Content-type: multipart/form-data; " ++ "boundary=" ++ boundary ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out - resp <- readFile responseFile - return (code, resp) + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) puthttpfile verbosity uri path auth headers = - withTempFile (takeDirectory path) "response" $ \responseFile responseHandle -> do + withTempFile (takeDirectory path) "response" $ + \responseFile responseHandle -> do hClose responseHandle let args = [ "--method=PUT", "--body-file="++path , "--user-agent=" ++ userAgent @@ -465,9 +489,10 @@ | Header name value <- headers ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out - resp <- readFile responseFile - return (code, resp) + (code, _etag) <- parseOutput verbosity uri out + withFile responseFile ReadMode $ \hnd -> do + resp <- hGetContents hnd + evaluate $ force (code, resp) addUriAuth Nothing uri = uri addUriAuth (Just (user, pass)) uri = uri @@ -490,14 +515,14 @@ -- wget returns exit code 8 for server "errors" like "304 not modified" if exitCode == ExitSuccess || exitCode == ExitFailure 8 then return resp - else die $ "'" ++ programPath prog + else die' verbosity $ "'" ++ programPath prog ++ "' exited with an error:\n" ++ resp -- With the --server-response flag, wget produces output with the full -- http server response with all headers, we want to find a line like -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple -- requests due to redirects. - parseOutput uri resp = + parseOutput verbosity uri resp = let parsedCode = listToMaybe [ code | (protocol:codestr:_err) <- map words (reverse (lines resp)) @@ -509,7 +534,7 @@ | ["ETag:", etag] <- map words (reverse (lines resp)) ] in case parsedCode of Just i -> return (i, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp powershellTransport :: ConfiguredProgram -> HttpTransport @@ -529,7 +554,7 @@ where parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of Just i -> return (i, Nothing) -- TODO extract real etag - Nothing -> statusParseFail uri x + Nothing -> statusParseFail verbosity uri x etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] posthttp = noPostYet @@ -547,14 +572,14 @@ resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) (uploadFileAction "POST" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp puthttpfile verbosity uri path auth headers = do fullPath <- canonicalizePath path resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) (uploadFileAction "PUT" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp runPowershellScript verbosity script = do let args = @@ -593,10 +618,10 @@ , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));" ] - parseUploadResponse uri resp = case lines (trim resp) of + parseUploadResponse verbosity uri resp = case lines (trim resp) of (codeStr : message) | Just code <- readMaybe codeStr -> return (code, unlines message) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp webclientScript setup action = unlines [ "$wc = new-object system.net.webclient;" @@ -641,6 +666,7 @@ (_, resp) <- cabalBrowse verbosity Nothing (request req) let code = convertRspCode (rspCode resp) etag' = lookupHeader HdrETag (rspHeaders resp) + -- 206 Partial Content is a normal response to a range request; see #3385. when (code==200 || code==206) $ writeFileAtomic destPath $ rspBody resp return (code, etag') @@ -689,7 +715,7 @@ p <- fixupEmptyProxy <$> fetchProxy True Exception.handleJust (guard . isDoesNotExistError) - (const . die $ "Couldn't establish HTTP connection. " + (const . die' verbosity $ "Couldn't establish HTTP connection. " ++ "Possible cause: HTTP proxy server is down.") $ browse $ do setProxy p @@ -713,9 +739,9 @@ , " (", display buildOS, "; ", display buildArch, ")" ] -statusParseFail :: URI -> String -> IO a -statusParseFail uri r = - die $ "Failed to download " ++ show uri ++ " : " +statusParseFail :: Verbosity -> URI -> String -> IO a +statusParseFail verbosity uri r = + die' verbosity $ "Failed to download " ++ show uri ++ " : " ++ "No Status Code could be parsed from response: " ++ r -- Trim diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.IndexUtils @@ -21,62 +23,74 @@ getSourcePackages, getSourcePackagesMonitorFiles, + IndexState(..), + getSourcePackagesAtIndexState, + Index(..), PackageEntry(..), parsePackageIndex, updateRepoIndexCache, updatePackageIndexCacheFile, - readCacheStrict, + readCacheStrict, -- only used by soon-to-be-obsolete sandbox code BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types +import Distribution.Verbosity import Distribution.Package - ( PackageId, PackageIdentifier(..), PackageName(..) - , Package(..), packageVersion, packageName - , Dependency(Dependency) ) -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.PackageIndex as PackageIndex + ( PackageId, PackageIdentifier(..), mkPackageName + , Package(..), packageVersion, packageName ) +import Distribution.Types.Dependency import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription ( GenericPackageDescription ) -import Distribution.PackageDescription.Parse - ( parsePackageDescription ) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program - ( ProgramConfiguration ) + ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages, getInstalledPackagesMonitorFiles ) -import Distribution.ParseUtils - ( ParseResult(..) ) import Distribution.Version - ( Version(Version), intersectVersionRanges ) + ( mkVersion, intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) -import Distribution.Verbosity - ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( die, warn, info, fromUTF8, ignoreBOM ) + ( die', warn, info ) import Distribution.Client.Setup ( RepoContext(..) ) -import Data.Char (isAlphaNum) -import Data.Maybe (mapMaybe, catMaybes, maybeToList) -import Data.List (isPrefixOf) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescriptionMaybe ) +import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse +#else +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.PackageDescription.Parse + ( parseGenericPackageDescription ) +import Distribution.Simple.Utils + ( fromUTF8, ignoreBOM ) +import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse #endif + +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + import qualified Data.Map as Map -import Control.Monad (when, liftM) -import Control.Exception (evaluate) +import Control.DeepSeq +import Control.Monad +import Control.Exception import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS @@ -84,8 +98,9 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath , tryFindAddSourcePackageDesc ) +import Distribution.Compat.Binary import Distribution.Compat.Exception (catchIO) -import Distribution.Client.Compat.Time (getFileAge, getModTime) +import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath ( (), (<.>), takeExtension, replaceExtension, splitDirectories, normalise ) @@ -100,10 +115,10 @@ -- | Reduced-verbosity version of 'Configure.getInstalledPackages' getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramConfiguration + -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDbs conf = - Configure.getInstalledPackages verbosity' comp packageDbs conf +getInstalledPackages verbosity comp packageDbs progdb = + Configure.getInstalledPackages verbosity' comp packageDbs progdb where verbosity' = lessVerbose verbosity @@ -128,6 +143,48 @@ -- Reading the source package index -- +-- Note: 'data IndexState' is defined in +-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles + +-- | 'IndexStateInfo' contains meta-information about the resulting +-- filtered 'Cache' 'after applying 'filterCache' according to a +-- requested 'IndexState'. +data IndexStateInfo = IndexStateInfo + { isiMaxTime :: !Timestamp + -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current + -- filtered view of the cache. + -- + -- The following property holds + -- + -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi) + -- + + , isiHeadTime :: !Timestamp + -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest + -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to + -- 'isiMaxTime'. + } + +emptyStateInfo :: IndexStateInfo +emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp + +-- | Filters a 'Cache' according to an 'IndexState' +-- specification. Also returns 'IndexStateInfo' describing the +-- resulting index cache. +-- +-- Note: 'filterCache' is idempotent in the 'Cache' value +filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo) +filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) + where + isiMaxTime = cacheHeadTs cache + isiHeadTime = cacheHeadTs cache +filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..}) + where + cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime } + isiHeadTime = cacheHeadTs cache0 + isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents) + ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0) + -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. -- @@ -136,16 +193,70 @@ -- -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb -getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." - return SourcePackageDb { - packageIndex = mempty, - packagePreferences = mempty - } -getSourcePackages verbosity repoCtxt = do - info verbosity "Reading available packages..." - pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt) +getSourcePackages verbosity repoCtxt = + getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead + +-- | Variant of 'getSourcePackages' which allows getting the source +-- packages at a particular 'IndexState'. +-- +-- Current choices are either the latest (aka HEAD), or the index as +-- it was at a particular time. +-- +-- TODO: Enhance to allow specifying per-repo 'IndexState's and also +-- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ +-- to access it) +getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState + -> IO SourcePackageDb +getSourcePackagesAtIndexState verbosity repoCtxt _ + | null (repoContextRepos repoCtxt) = do + -- In the test suite, we routinely don't have any remote package + -- servers, so don't bleat about it + warn (verboseUnmarkOutput verbosity) $ + "No remote package servers have been specified. Usually " ++ + "you would have one specified in the config file." + return SourcePackageDb { + packageIndex = mempty, + packagePreferences = mempty + } +getSourcePackagesAtIndexState verbosity repoCtxt idxState = do + case idxState of + IndexStateHead -> info verbosity "Reading available packages..." + IndexStateTime time -> + info verbosity ("Reading available packages (for index-state as of " + ++ display time ++ ")...") + + pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do + let rname = maybe "" remoteRepoName $ maybeRepoRemote r + unless (idxState == IndexStateHead) $ + case r of + RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") + RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") + RepoSecure {} -> pure () + + + let idxState' = case r of + RepoSecure {} -> idxState + _ -> IndexStateHead + + (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState' + + case idxState' of + IndexStateHead -> do + info verbosity ("index-state("++rname++") = " ++ + display (isiHeadTime isi)) + return () + IndexStateTime ts0 -> do + when (isiMaxTime isi /= ts0) $ + warn verbosity ("Requested index-state " ++ display ts0 + ++ " does not exist in '"++rname++"'!" + ++ " Falling back to older state (" + ++ display (isiMaxTime isi) ++ ").") + info verbosity ("index-state("++rname++") = " ++ + display (isiMaxTime isi) ++ " (HEAD = " ++ + display (isiHeadTime isi) ++ ")") + + pure (pis,deps) + let (pkgs, prefs) = mconcat pkgss prefs' = Map.fromListWith intersectVersionRanges [ (name, range) | Dependency name range <- prefs ] @@ -159,9 +270,9 @@ readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do updateRepoIndexCache verbosity index - cache <- liftM readIndexCache $ BSS.readFile (cacheFile index) + cache <- readIndexCache verbosity index withFile (indexFile index) ReadMode $ \indexHnd -> - packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict + packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. @@ -170,13 +281,15 @@ -- -- This is a higher level wrapper used internally in cabal-install. -- -readRepoIndex :: Verbosity -> RepoContext -> Repo - -> IO (PackageIndex SourcePackage, [Dependency]) -readRepoIndex verbosity repoCtxt repo = +readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState + -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) +readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do warnIfIndexIsOld =<< getIndexFileAge repo updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo) + readPackageIndexCacheFile verbosity mkAvailablePackage + (RepoIndex repoCtxt repo) + idxState where mkAvailablePackage pkgEntry = @@ -201,7 +314,7 @@ RepoLocal{..} -> warn verbosity $ "The package list for the local repo '" ++ repoLocalDir ++ "' is missing. The repo is invalid." - return mempty + return (mempty,mempty,emptyStateInfo) else ioError e isOldThreshold = 15 --days @@ -260,8 +373,10 @@ -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef - deriving Eq + deriving (Eq,Generic) +instance Binary BuildTreeRefType + refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t | t == Tar.buildTreeRefTypeCode = LinkRef @@ -295,14 +410,14 @@ -- function over this to translate it to a list of IO actions returning -- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of -- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. -parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)] -parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read +parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] +parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read where extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] extract blockNo entry = tryExtractPkg ++ tryExtractPrefs where tryExtractPkg = do - mkPkgEntry <- maybeToList $ extractPkg entry blockNo + mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo return $ fmap (fmap Pkg) mkPkgEntry tryExtractPrefs = do @@ -321,21 +436,29 @@ go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' -extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) -extractPkg entry blockNo = case Tar.entryContent entry of +extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) +extractPkg verbosity entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of [pkgname,vers,_] -> case simpleParse vers of Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) where - pkgid = PackageIdentifier (PackageName pkgname) ver - parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack + pkgid = PackageIdentifier (mkPackageName pkgname) ver +#ifdef CABAL_PARSEC + parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) + descr = case parsed of + Just d -> d + Nothing -> error $ "Couldn't read cabal file " + ++ show fileName +#else + parsed = parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content descr = case parsed of ParseOk _ d -> d _ -> error $ "Couldn't read cabal file " ++ show fileName +#endif _ -> Nothing _ -> Nothing @@ -346,8 +469,8 @@ dirExists <- doesDirectoryExist path result <- if not dirExists then return Nothing else do - cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index." - descr <- PackageDesc.Parse.readPackageDescription normal cabalFile + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." + descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) descr path blockNo return result @@ -390,6 +513,19 @@ xs' <- lazySequence xs return (x' : xs') +-- | A lazy unfolder for lookup operations which return the current +-- value and (possibly) the next key +lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)] +lazyUnfold step = goLazy . Just + where + goLazy s = unsafeInterleaveIO (go s) + + go Nothing = return [] + go (Just k) = do + (v, mk') <- step k + vs' <- goLazy mk' + return ((k,v):vs') + -- | Which index do we mean? data Index = -- | The main index for the specified repository @@ -407,12 +543,26 @@ cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index) = index `replaceExtension` "cache" +-- | Return 'True' if 'Index' uses 01-index format (aka secure repo) +is01Index :: Index -> Bool +is01Index (RepoIndex _ repo) = case repo of + RepoSecure {} -> True + RepoRemote {} -> False + RepoLocal {} -> False +is01Index (SandboxIndex _) = False + + updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do - info verbosity ("Updating index cache file " ++ cacheFile index) - withIndexEntries index $ \entries -> do - let cache = Cache { cacheEntries = entries } - writeFile (cacheFile index) (showIndexCache cache) + info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") + withIndexEntries verbosity index $ \entries -> do + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = Cache { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info verbosity ("Index cache updated to index-state " + ++ display (cacheHeadTs cache)) -- | Read the index (for the purpose of building a cache) -- @@ -434,73 +584,94 @@ -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. -withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a -withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback = +withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do - let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile)) - -> IO [IndexCacheEntry] - mk (_, _fp, Nothing) = - return [] -- skip unrecognized file - mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) = - return [] -- skip metadata - mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do - let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry) - return [CachePackageId pkgId blockNo] - mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do - content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file - return $ map CachePreference (parsePreferredVersions content) - entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory) - callback $ concat entriess -withIndexEntries index callback = do + -- Incrementally (lazily) read all the entries in the tar file in order, + -- including all revisions, not just the last revision of each file + indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory) + callback [ cacheEntry + | (dirEntry, indexEntry) <- indexEntries + , cacheEntry <- toCacheEntries dirEntry indexEntry ] + where + toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry + -> [IndexCacheEntry] + toCacheEntries dirEntry (Sec.Some sie) = + case Sec.indexEntryPathParsed sie of + Nothing -> [] -- skip unrecognized file + Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata + Just (Sec.IndexPkgCabal pkgId) -> force + [CachePackageId pkgId blockNo timestamp] + Just (Sec.IndexPkgPrefs _pkgName) -> force + [ CachePreference dep blockNo timestamp + | dep <- parsePreferredVersions (Sec.indexEntryContent sie) + ] + where + blockNo = Sec.directoryEntryBlockNo dirEntry + timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ + epochTimeToTimestamp $ Sec.indexEntryTime sie + +withIndexEntries verbosity index callback = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex bs + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs callback $ map toCache (catMaybes pkgsOrPrefs) where toCache :: PackageOrDep -> IndexCacheEntry - toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo + toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo - toCache (Dep d) = CachePreference d + toCache (Dep d) = CachePreference d 0 nullTimestamp data ReadPackageIndexMode = ReadPackageIndexStrict | ReadPackageIndexLazyIO readPackageIndexCacheFile :: Package pkg - => (PackageEntry -> pkg) + => Verbosity + -> (PackageEntry -> pkg) -> Index - -> IO (PackageIndex pkg, [Dependency]) -readPackageIndexCacheFile mkPkg index = do - cache <- liftM readIndexCache $ BSS.readFile (cacheFile index) - indexHnd <- openFile (indexFile index) ReadMode - packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO + -> IndexState + -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) +readPackageIndexCacheFile verbosity mkPkg index idxState = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache,isi) = filterCache idxState cache0 + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO + pure (pkgs,deps,isi) + packageIndexFromCache :: Package pkg - => (PackageEntry -> pkg) + => Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache mkPkg hnd cache mode = do - (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode +packageIndexFromCache verbosity mkPkg hnd cache mode = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) -- | Read package list -- --- The result packages (though not the preferences) are guaranteed to be listed --- in the same order as they are in the tar file (because later entries in a tar --- file mask earlier ones). -packageListFromCache :: (PackageEntry -> pkg) +-- The result package releases and preference entries are guaranteed +-- to be unique. +-- +-- Note: 01-index.tar is an append-only index and therefore contains +-- all .cabal edits and preference-updates. The masking happens +-- here, i.e. the semantics that later entries in a tar file mask +-- earlier ones is resolved in this function. +packageListFromCache :: Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO ([pkg], [Dependency]) -packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries +packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries where - accum srcpkgs prefs [] = return (reverse srcpkgs, prefs) + accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) - accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do + accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do -- Given the cache entry, make a package index entry. -- The magic here is that we use lazy IO to read the .cabal file -- from the index tarball if it turns out that we need it. @@ -509,27 +680,25 @@ pkgtxt <- getEntryContent blockno pkg <- readPackageDescription pkgtxt return (pkg, pkgtxt) - let srcpkg = case mode of - ReadPackageIndexLazyIO -> - mkPkg (NormalPackage pkgid pkg pkgtxt blockno) - ReadPackageIndexStrict -> - pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg - pkgtxt blockno) - accum (srcpkg:srcpkgs) prefs entries + case mode of + ReadPackageIndexLazyIO -> pure () + ReadPackageIndexStrict -> evaluate pkg *> evaluate pkgtxt *> pure () + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) + accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries - accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do + accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do -- We have to read the .cabal file eagerly here because we can't cache the -- package id for build tree references - the user might edit the .cabal -- file after the reference was added to the index. path <- liftM byteStringToFilePath . getEntryContent $ blockno pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc path err - PackageDesc.Parse.readPackageDescription normal file + file <- tryFindAddSourcePackageDesc verbosity path err + PackageDesc.Parse.readGenericPackageDescription normal file let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) - accum (srcpkg:srcpkgs) prefs entries + accum srcpkgs (srcpkg:btrs) prefs entries - accum srcpkgs prefs (CachePreference pref : entries) = - accum srcpkgs (pref:prefs) entries + accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) _ _ : entries) = + accum srcpkgs btrs (Map.insert pn pref prefs) entries getEntryContent :: BlockNo -> IO ByteString getEntryContent blockno = do @@ -543,11 +712,18 @@ readPackageDescription :: ByteString -> IO GenericPackageDescription readPackageDescription content = - case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of +#ifdef CABAL_PARSEC + case parseGenericPackageDescriptionMaybe (BS.toStrict content) of + Just gpd -> return gpd + Nothing -> interror "failed to parse .cabal file" +#else + case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of ParseOk _ d -> return d _ -> interror "failed to parse .cabal file" +#endif - interror msg = die $ "internal error when reading package index: " ++ msg + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg ++ "The package index or index cache is probably " ++ "corrupt. Running cabal update might fix it." @@ -555,31 +731,156 @@ -- Index cache data structure -- +-- | Read the 'Index' cache from the filesystem +-- +-- If a corrupted index cache is detected this function regenerates +-- the index cache and then reattempt to read the index once (and +-- 'die's if it fails again). +readIndexCache :: Verbosity -> Index -> IO Cache +readIndexCache verbosity index = do + cacheOrFail <- readIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index + + Right res -> return (hashConsCache res) + +-- | Read the 'Index' cache from the filesystem without attempting to +-- regenerate on parsing failures. +readIndexCache' :: Index -> IO (Either String Cache) +readIndexCache' index + | is01Index index = decodeFileOrFail' (cacheFile index) + | otherwise = liftM (Right .read00IndexCache) $ + BSS.readFile (cacheFile index) + +-- | Write the 'Index' cache to the filesystem +writeIndexCache :: Index -> Cache -> IO () +writeIndexCache index cache + | is01Index index = encodeFile (cacheFile index) cache + | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + +-- | Optimise sharing of equal values inside 'Cache' +-- +-- c.f. https://en.wikipedia.org/wiki/Hash_consing +hashConsCache :: Cache -> Cache +hashConsCache cache0 + = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) } + where + -- TODO/NOTE: + -- + -- If/when we redo the binary serialisation via e.g. CBOR and we + -- are able to use incremental decoding, we may want to move the + -- hash-consing into the incremental deserialisation, or + -- alterantively even do something like + -- http://cbor.schmorp.de/value-sharing + -- + go _ _ [] = [] + -- for now we only optimise only CachePackageIds since those + -- represent the vast majority + go !pns !pvs (CachePackageId pid bno ts : rest) + = CachePackageId pid' bno ts : go pns' pvs' rest + where + !pid' = PackageIdentifier pn' pv' + (!pn',!pns') = mapIntern pn pns + (!pv',!pvs') = mapIntern pv pvs + PackageIdentifier pn pv = pid + + go pns pvs (x:xs) = x : go pns pvs xs + + mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k) + mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m) + +-- | Cabal caches various information about the Hackage index +data Cache = Cache + { cacheHeadTs :: Timestamp + -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the + -- invariant of 'cacheEntries' being in chronological order is + -- violated, this corresponds to the last (seen) 'Timestamp' in + -- 'cacheEntries' + , cacheEntries :: [IndexCacheEntry] + } + +instance NFData Cache where + rnf = rnf . cacheEntries + -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. -- -type BlockNo = Tar.TarEntryOffset +type BlockNo = Word32 -- Tar.TarEntryOffset -data IndexCacheEntry = CachePackageId PackageId BlockNo - | CacheBuildTreeRef BuildTreeRefType BlockNo - | CachePreference Dependency - deriving (Eq) -installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String -installedUnitId = "pkg:" +data IndexCacheEntry + = CachePackageId PackageId !BlockNo !Timestamp + | CachePreference Dependency !BlockNo !Timestamp + | CacheBuildTreeRef !BuildTreeRefType !BlockNo + -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build + deriving (Eq,Generic) + +instance NFData IndexCacheEntry where + rnf (CachePackageId pkgid _ _) = rnf pkgid + rnf (CachePreference dep _ _) = rnf dep + rnf (CacheBuildTreeRef _ _) = () + +cacheEntryTimestamp :: IndexCacheEntry -> Timestamp +cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp +cacheEntryTimestamp (CachePreference _ _ ts) = ts +cacheEntryTimestamp (CachePackageId _ _ ts) = ts + +---------------------------------------------------------------------------- +-- new binary 01-index.cache format + +instance Binary Cache where + put (Cache headTs ents) = do + -- magic / format version + -- + -- NB: this currently encodes word-size implicitly; when we + -- switch to CBOR encoding, we will have a platform + -- independent binary encoding + put (0xcaba1002::Word) + put headTs + put ents + + get = do + magic <- get + when (magic /= (0xcaba1002::Word)) $ + fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic) + Cache <$> get <*> get + +instance Binary IndexCacheEntry + +---------------------------------------------------------------------------- +-- legacy 00-index.cache format + +packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String +packageKey = "pkg:" blocknoKey = "b#" buildTreeRefKey = "build-tree-ref:" preferredVersionKey = "pref-ver:" -readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry -readIndexCacheEntry = \line -> +-- legacy 00-index.cache format +read00IndexCache :: BSS.ByteString -> Cache +read00IndexCache bs = Cache + { cacheHeadTs = nullTimestamp + , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs + } + +read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry +read00IndexCacheEntry = \line -> case BSS.words line of [key, pkgnamestr, pkgverstr, sep, blocknostr] - | key == BSS.pack installedUnitId && sep == BSS.pack blocknoKey -> + | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of (Just pkgname, Just pkgver, Just blockno) - -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) + -> Just (CachePackageId (PackageIdentifier pkgname pkgver) + blockno nullTimestamp) _ -> Nothing [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> case (parseRefType typecodestr, parseBlockNo blocknostr) of @@ -587,13 +888,15 @@ -> Just (CacheBuildTreeRef refType blockno) _ -> Nothing - (key: remainder) | key == BSS.pack preferredVersionKey -> - fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder))) + (key: remainder) | key == BSS.pack preferredVersionKey -> do + pref <- simpleParse (BSS.unpack (BSS.unwords remainder)) + return $ CachePreference pref 0 nullTimestamp + _ -> Nothing where parseName str | BSS.all (\c -> isAlphaNum c || c == '-') str - = Just (PackageName (BSS.unpack str)) + = Just (mkPackageName (BSS.unpack str)) | otherwise = Nothing parseVer str vs = @@ -602,7 +905,7 @@ Just (v, str') -> case BSS.uncons str' of Just ('.', str'') -> parseVer str'' (v:vs) Just _ -> Nothing - Nothing -> Just (Version (reverse (v:vs)) []) + Nothing -> Just (mkVersion (reverse (v:vs))) parseBlockNo str = case BSS.readInt str of @@ -617,31 +920,22 @@ -> Just (refTypeFromTypeCode typeCode) _ -> Nothing -showIndexCacheEntry :: IndexCacheEntry -> String -showIndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b -> [ installedUnitId - , display (packageName pkgid) - , display (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef t b -> [ buildTreeRefKey - , [typeCodeFromRefType t] - , show b - ] - CachePreference dep -> [ preferredVersionKey - , display dep - ] - --- | Cabal caches various information about the Hackage index -data Cache = Cache { - cacheEntries :: [IndexCacheEntry] - } - -readIndexCache :: BSS.ByteString -> Cache -readIndexCache bs = Cache { - cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs - } +-- legacy 00-index.cache format +show00IndexCache :: Cache -> String +show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries -showIndexCache :: Cache -> String -showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries +show00IndexCacheEntry :: IndexCacheEntry -> String +show00IndexCacheEntry entry = unwords $ case entry of + CachePackageId pkgid b _ -> [ packageKey + , display (packageName pkgid) + , display (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> [ preferredVersionKey + , display dep + ] diff --git a/Distribution/Client/IndexUtils/Timestamp.hs b/Distribution/Client/IndexUtils/Timestamp.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/IndexUtils/Timestamp.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils.Timestamp +-- Copyright : (c) 2016 Herbert Valerio Riedel +-- License : BSD3 +-- +-- Timestamp type used in package indexes + +module Distribution.Client.IndexUtils.Timestamp + ( Timestamp + , nullTimestamp + , epochTimeToTimestamp + , timestampToUTCTime + , utcTimeToTimestamp + , maximumTimestamp + + , IndexState(..) + ) where + +import qualified Codec.Archive.Tar.Entry as Tar +import Control.DeepSeq +import Control.Monad +import Data.Char (isDigit) +import Data.Int (Int64) +import Data.Time (UTCTime (..), fromGregorianValid, + makeTimeOfDayValid, showGregorian, + timeOfDayToTime, timeToTimeOfDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, + utcTimeToPOSIXSeconds) +import Distribution.Compat.Binary +import qualified Distribution.Compat.ReadP as ReadP +import Distribution.Text +import qualified Text.PrettyPrint as Disp +import GHC.Generics (Generic) + +-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). +newtype Timestamp = TS Int64 -- Tar.EpochTime + deriving (Eq,Ord,Enum,NFData,Show) + +epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp +epochTimeToTimestamp et + | ts == nullTimestamp = Nothing + | otherwise = Just ts + where + ts = TS et + +timestampToUTCTime :: Timestamp -> Maybe UTCTime +timestampToUTCTime (TS t) + | t == minBound = Nothing + | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t) + +utcTimeToTimestamp :: UTCTime -> Maybe Timestamp +utcTimeToTimestamp utct + | minTime <= t, t <= maxTime = Just (TS (fromIntegral t)) + | otherwise = Nothing + where + maxTime = toInteger (maxBound :: Int64) + minTime = toInteger (succ minBound :: Int64) + t :: Integer + t = round . utcTimeToPOSIXSeconds $ utct + +-- | Compute the maximum 'Timestamp' value +-- +-- Returns 'nullTimestamp' for the empty list. Also note that +-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp' +-- values. +maximumTimestamp :: [Timestamp] -> Timestamp +maximumTimestamp [] = nullTimestamp +maximumTimestamp xs@(_:_) = maximum xs + +-- returns 'Nothing' if not representable as 'Timestamp' +posixSecondsToTimestamp :: Integer -> Maybe Timestamp +posixSecondsToTimestamp pt + | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt)) + | otherwise = Nothing + where + maxTs = toInteger (maxBound :: Int64) + minTs = toInteger (succ minBound :: Int64) + +-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format +-- (e.g. @"2017-12-31T23:59:59Z"@) +-- +-- Returns empty string for 'nullTimestamp' in order for +-- +-- > null (display nullTimestamp) == True +-- +-- to hold. +showTimestamp :: Timestamp -> String +showTimestamp ts = case timestampToUTCTime ts of + Nothing -> "" + -- Note: we don't use 'formatTime' here to avoid incurring a + -- dependency on 'old-locale' for older `time` libs + Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z" + where + showTOD = show . timeToTimeOfDay + +instance Binary Timestamp where + put (TS t) = put t + get = TS `fmap` get + +instance Text Timestamp where + disp = Disp.text . showTimestamp + + parse = parsePosix ReadP.+++ parseUTC + where + -- | Parses unix timestamps, e.g. @"\@1474626019"@ + parsePosix = do + _ <- ReadP.char '@' + t <- parseInteger + maybe ReadP.pfail return $ posixSecondsToTimestamp t + + -- | Parses ISO8601/RFC3339-style UTC timestamps, + -- e.g. @"2017-12-31T23:59:59Z"@ + -- + -- TODO: support numeric tz offsets; allow to leave off seconds + parseUTC = do + -- Note: we don't use 'Data.Time.Format.parseTime' here since + -- we want more control over the accepted formats. + + ye <- parseYear + _ <- ReadP.char '-' + mo <- parseTwoDigits + _ <- ReadP.char '-' + da <- parseTwoDigits + _ <- ReadP.char 'T' + + utctDay <- maybe ReadP.pfail return $ + fromGregorianValid ye mo da + + ho <- parseTwoDigits + _ <- ReadP.char ':' + mi <- parseTwoDigits + _ <- ReadP.char ':' + se <- parseTwoDigits + _ <- ReadP.char 'Z' + + utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $ + makeTimeOfDayValid ho mi (realToFrac (se::Int)) + + maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..}) + + parseTwoDigits = do + d1 <- ReadP.satisfy isDigit + d2 <- ReadP.satisfy isDigit + return (read [d1,d2]) + + -- A year must have at least 4 digits; e.g. "0097" is fine, + -- while "97" is not c.f. RFC3339 which + -- deprecates 2-digit years + parseYear = do + sign <- ReadP.option ' ' (ReadP.char '-') + ds <- ReadP.munch1 isDigit + when (length ds < 4) ReadP.pfail + return (read (sign:ds)) + + parseInteger = do + sign <- ReadP.option ' ' (ReadP.char '-') + ds <- ReadP.munch1 isDigit + return (read (sign:ds) :: Integer) + +-- | Special timestamp value to be used when 'timestamp' is +-- missing/unknown/invalid +nullTimestamp :: Timestamp +nullTimestamp = TS minBound + +---------------------------------------------------------------------------- +-- defined here for now to avoid import cycles + +-- | Specification of the state of a specific repo package index +data IndexState = IndexStateHead -- ^ Use all available entries + | IndexStateTime !Timestamp -- ^ Use all entries that existed at + -- the specified time + deriving (Eq,Generic,Show) + +instance Binary IndexState +instance NFData IndexState + +instance Text IndexState where + disp IndexStateHead = Disp.text "HEAD" + disp (IndexStateTime ts) = disp ts + + parse = parseHead ReadP.+++ parseTime + where + parseHead = do + _ <- ReadP.string "HEAD" + return IndexStateHead + + parseTime = IndexStateTime `fmap` parse diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init @@ -23,48 +22,40 @@ ) where +import Prelude () +import Distribution.Client.Compat.Prelude hiding (empty) + import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath - ( (), (<.>), takeBaseName ) + ( (), (<.>), takeBaseName, equalFilePath ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) -import Data.Char - ( toUpper ) import Data.List - ( intercalate, nub, groupBy, (\\) ) -import Data.Maybe - ( fromMaybe, isJust, catMaybes, listToMaybe ) + ( groupBy, (\\) ) import Data.Function ( on ) import qualified Data.Map as M -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative - ( (<$>) ) -import Data.Traversable - ( traverse ) -#endif import Control.Monad - ( when, unless, (>=>), join, forM_ ) + ( (>=>), join, forM_, mapM, mapM_ ) import Control.Arrow ( (&&&), (***) ) import Text.PrettyPrint hiding (mode, cat) -import Data.Version - ( Version(..) ) import Distribution.Version - ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) + ( Version, mkVersion, alterVersion + , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity ( Verbosity ) import Distribution.ModuleName - ( ModuleName, fromString ) -- And for the Text instance + ( ModuleName ) -- And for the Text instance import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, sourcePackageId, exposed ) + ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P import Language.Haskell.Extension ( Language(..) ) @@ -89,14 +80,15 @@ import Distribution.Simple.Compiler ( PackageDBStack, Compiler ) import Distribution.Simple.Program - ( ProgramConfiguration ) + ( ProgramDb ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) -import Distribution.Client.PackageIndex +import Distribution.Solver.Types.PackageIndex ( elemByPackageName ) + import Distribution.Client.IndexUtils ( getSourcePackages ) import Distribution.Client.Types @@ -108,12 +100,12 @@ -> PackageDBStack -> RepoContext -> Compiler - -> ProgramConfiguration + -> ProgramDb -> InitFlags -> IO () -initCabal verbosity packageDBs repoCtxt comp conf initFlags = do +initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt hSetBuffering stdout NoBuffering @@ -202,7 +194,7 @@ -- if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do - let v = Just $ Version [0,1,0,0] [] + let v = Just $ mkVersion [0,1,0,0] v' <- return (flagToMaybe $ version flags) ?>> maybePrompt flags (prompt "Package version" v) ?>> return v @@ -380,14 +372,21 @@ then Just "src" else Nothing +-- | Check whether a potential source file is located in one of the +-- source directories. +isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool +isSourceFile Nothing sf = isSourceFile (Just ["."]) sf +isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs + -- | Get the list of exposed modules and extra tools needed to build them. getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags - -- TODO: really should use guessed source roots. - sourceFiles <- scanForModules dir + sourceFiles0 <- scanForModules dir + let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0 + Just mods <- return (exposedModules flags) ?>> (return . Just . map moduleName $ sourceFiles) @@ -455,7 +454,7 @@ message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where - pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps) + pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) -- Given a list of available versions of the same package, pick a dependency. toDep :: [P.PackageIdentifier] -> IO P.Dependency @@ -477,11 +476,11 @@ pvpize v = orLaterVersion v' `intersectVersionRanges` earlierVersion (incVersion 1 v') - where v' = (v { versionBranch = take 2 (versionBranch v) }) + where v' = alterVersion (take 2) v -- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version -incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags +incVersion n = alterVersion (incVersion' n) where incVersion' 0 [] = [1] incVersion' 0 (v:_) = [v+1] @@ -603,11 +602,6 @@ = return . Right $ choices !! (n-1) | otherwise = Left `fmap` promptStr "Please specify" Nothing -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(a,"")] -> Just a - _ -> Nothing - --------------------------------------------------------------------------- -- File generation ------------------------------------------------------ --------------------------------------------------------------------------- @@ -625,28 +619,28 @@ Flag BSD3 -> Just $ bsd3 authors year - Flag (GPL (Just (Version {versionBranch = [2]}))) + Flag (GPL (Just v)) | v == mkVersion [2] -> Just gplv2 - Flag (GPL (Just (Version {versionBranch = [3]}))) + Flag (GPL (Just v)) | v == mkVersion [3] -> Just gplv3 - Flag (LGPL (Just (Version {versionBranch = [2, 1]}))) + Flag (LGPL (Just v)) | v == mkVersion [2,1] -> Just lgpl21 - Flag (LGPL (Just (Version {versionBranch = [3]}))) + Flag (LGPL (Just v)) | v == mkVersion [3] -> Just lgpl3 - Flag (AGPL (Just (Version {versionBranch = [3]}))) + Flag (AGPL (Just v)) | v == mkVersion [3] -> Just agplv3 - Flag (Apache (Just (Version {versionBranch = [2, 0]}))) + Flag (Apache (Just v)) | v == mkVersion [2,0] -> Just apache20 Flag MIT -> Just $ mit authors year - Flag (MPL (Version {versionBranch = [2, 0]})) + Flag (MPL v) | v == mkVersion [2,0] -> Just mpl20 Flag ISC @@ -850,7 +844,7 @@ (Just "Extra files to be distributed with the package, such as examples or a README.") True - , field "cabal-version" (Flag $ orLaterVersion (Version [1,10] [])) + , field "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10])) (Just "Constraint on the version of Cabal needed to build this package.") False @@ -924,9 +918,9 @@ (True, _, _) -> (showComment com $$) . ($$ text "") (False, _, _) -> ($$ text "") $ - comment f <> text s <> colon - <> text (replicate (20 - length s) ' ') - <> text (fromMaybe "" . flagToMaybe $ f) + comment f <<>> text s <<>> colon + <<>> text (replicate (20 - length s) ' ') + <<>> text (fromMaybe "" . flagToMaybe $ f) comment NoFlag = text "-- " comment (Flag "") = text "-- " comment _ = text "" 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init.Heuristics @@ -20,32 +19,31 @@ guessAuthorNameMail, knownCategories, ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Text (simpleParse) import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName ( ModuleName, toFilePath ) -import Distribution.Client.PackageIndex - ( allPackagesByName ) import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD ( category, packageDescription ) -import Distribution.Simple.Utils - ( intercalate ) import Distribution.Client.Utils ( tryCanonicalizePath ) import Language.Haskell.Extension ( Extension ) -import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ( pure, (<$>), (<*>) ) -import Data.Monoid ( mempty, mappend, mconcat ) -#endif -import Control.Arrow ( first ) -import Control.Monad ( liftM ) -import Data.Char ( isAlphaNum, isNumber, isUpper, isLower, isSpace ) +import Distribution.Solver.Types.PackageIndex + ( allPackagesByName ) +import Distribution.Solver.Types.SourcePackage + ( packageDescription ) + +import Distribution.Client.Types ( SourcePackageDb(..) ) +import Control.Monad ( mapM ) +import Data.Char ( isNumber, isLower ) import Data.Either ( partitionEithers ) -import Data.List ( isInfixOf, isPrefixOf, isSuffixOf, sortBy ) -import Data.Maybe ( mapMaybe, catMaybes, maybeToList ) +import Data.List ( isInfixOf ) import Data.Ord ( comparing ) import qualified Data.Set as Set ( fromList, toList ) import System.Directory ( getCurrentDirectory, getDirectoryContents, @@ -88,7 +86,7 @@ -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.PackageName . repair . last . splitDirectories) +guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories) . tryCanonicalizePath where -- Treat each span of non-alphanumeric characters as a hyphen. Each @@ -251,7 +249,11 @@ -- Ordered in increasing preference, since Flag-as-monoid is identical to -- Last. authorGuessPure :: AuthorGuessIO -> AuthorGuess -authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal) +authorGuessPure (AuthorGuessIO { authorGuessEnv = env + , authorGuessLocalDarcs = darcsLocalF + , authorGuessGlobalDarcs = darcsGlobalF + , authorGuessLocalGit = gitLocal + , authorGuessGlobalGit = gitGlobal }) = mconcat [ emailEnv env , gitGlobal @@ -275,12 +277,13 @@ type AuthorGuess = (Flag String, Flag String) type Enviro = [(String, String)] data GitLoc = Local | Global -data AuthorGuessIO = AuthorGuessIO - Enviro -- ^ Environment lookup table - (Maybe String) -- ^ Contents of local darcs author info - (Maybe String) -- ^ Contents of global darcs author info - AuthorGuess -- ^ Git config --local - AuthorGuess -- ^ Git config --global +data AuthorGuessIO = AuthorGuessIO { + authorGuessEnv :: Enviro, -- ^ Environment lookup table + authorGuessLocalDarcs :: (Maybe String), -- ^ Contents of local darcs author info + authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info + authorGuessLocalGit :: AuthorGuess, -- ^ Git config --local + authorGuessGlobalGit :: AuthorGuess -- ^ Git config --global + } darcsEnv :: Enviro -> AuthorGuess darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" 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 @@ -18,6 +18,7 @@ import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Types.Dependency as P import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity @@ -82,7 +83,7 @@ instance Text PackageType where disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] + parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse instance Monoid InitFlags where mempty = gmempty @@ -114,5 +115,5 @@ instance Text Category where disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] + parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -- TODO: eradicateNoParse diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -29,14 +29,13 @@ pruneInstallPlan ) where -import Data.Foldable - ( traverse_ ) +import Prelude () +import Distribution.Client.Compat.Prelude + import Data.List - ( isPrefixOf, unfoldr, nub, sort, (\\) ) + ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S -import Data.Maybe - ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe ) import Control.Exception as Exception ( Exception(toException), bracket, catches , Handler(Handler), handleJust, IOException, SomeException ) @@ -48,17 +47,12 @@ ( ExitCode(..) ) import Distribution.Compat.Exception ( catchIO, catchExit ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative - ( (<$>) ) -import Data.Traversable - ( traverse ) -#endif import Control.Monad - ( filterM, forM_, when, unless ) + ( forM_, mapM ) import System.Directory ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, - createDirectoryIfMissing, removeFile, renameDirectory ) + createDirectoryIfMissing, removeFile, renameDirectory, + getDirectoryContents ) import System.FilePath ( (), (<.>), equalFilePath, takeDirectory ) import System.IO @@ -71,15 +65,18 @@ ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types - ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) ) + ( Solver(..) ) import Distribution.Client.FetchUtils import Distribution.Client.HttpUtils ( HttpTransport (..) ) +import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages, getInstalledPackages ) + ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import Distribution.Client.Setup ( GlobalFlags(..), RepoContext(..) , ConfigFlags(..), configureCommand, filterConfigureFlags @@ -102,29 +99,33 @@ ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink ( symlinkBinaries ) -import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl -import qualified Distribution.Client.ComponentDeps as CD +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb, readPkgConfigDb ) +import Distribution.Solver.Types.SourcePackage as SourcePackage + import Distribution.Utils.NubList import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration, - defaultProgramConfiguration) +import Distribution.Simple.Program (ProgramDb) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.LocalBuildInfo (ComponentName(CLibName)) -import qualified Distribution.Simple.Configure as Configure import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags - , AllowNewer(..) + , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) @@ -132,41 +133,42 @@ , registerCommand, RegisterFlags(..), emptyRegisterFlags , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, rawSystemExit, comparing - , writeFileAtomic, withTempFile , withUTF8FileContents ) + ( createDirectoryIfMissingVerbose, comparing + , writeFileAtomic, withUTF8FileContents ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Simple.Configure (interpretPackageDbFlags) +import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) import Distribution.Package ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..) - , Dependency(..), thisPackageVersion - , UnitId(..), mkUnitId - , HasUnitId(..) ) + , Package(..), HasMungedPackageId(..), HasUnitId(..) + , UnitId ) +import Distribution.Types.Dependency + ( Dependency(..), thisPackageVersion ) +import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) - , FlagName(..), FlagAssignment ) + , FlagAssignment, showFlagValue ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Client.PkgConfigDb - ( PkgConfigDb, readPkgConfigDb ) + ( finalizePD ) import Distribution.ParseUtils ( showPWarning ) import Distribution.Version ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die - , intercalate, withTempDirectory ) + ( notice, info, warn, debug, debugNoWrap, die' + , withTempDirectory ) import Distribution.Client.Utils - ( determineNumJobs, inDir, logDirChange, mergeBy, MergeResult(..) + ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) , tryCanonicalizePath ) import Distribution.System ( Platform, OS(Windows), buildOS ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, showForCabal, normal, verbose ) + ( Verbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) --TODO: @@ -193,7 +195,7 @@ -> RepoContext -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> UseSandbox -> Maybe SandboxPackageInfo -> GlobalFlags @@ -203,10 +205,22 @@ -> HaddockFlags -> [UserTarget] -> IO () -install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo +install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do + unless (installRootCmd installFlags == Cabal.NoFlag) $ + warn verbosity $ "--root-cmd is no longer supported, " + ++ "see https://github.com/haskell/cabal/issues/3353" + ++ " (if you didn't type --root-cmd, comment out root-cmd" + ++ " in your ~/.cabal/config file)" + let userOrSandbox = fromFlag (configUserInstall configFlags) + || isUseSandbox useSandbox + unless userOrSandbox $ + warn verbosity $ "the --global flag is deprecated -- " + ++ "it is generally considered a bad idea to install packages " + ++ "into the global store" + installContext <- makeInstallContext verbosity args (Just userTargets0) planResult <- foldProgress logMsg (return . Left) (return . Right) =<< makeInstallPlan verbosity args installContext @@ -214,16 +228,16 @@ case planResult of Left message -> do reportPlanningFailure verbosity args installContext message - die' message + die'' message Right installPlan -> processInstallPlan verbosity args installContext installPlan where args :: InstallArgs - args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo, - globalFlags, configFlags, configExFlags, installFlags, - haddockFlags) + args = (packageDBs, repos, comp, platform, progdb, useSandbox, + mSandboxPkgInfo, globalFlags, configFlags, configExFlags, + installFlags, haddockFlags) - die' message = die (message ++ if isUseSandbox useSandbox + die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) -- TODO: use a better error message, remove duplication. installFailedInSandbox = @@ -237,7 +251,7 @@ -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( InstalledPackageIndex, SourcePackageDb , PkgConfigDb - , [UserTarget], [PackageSpecifier SourcePackage] + , [UserTarget], [PackageSpecifier UnresolvedSourcePackage] , HttpTransport ) -- TODO: Make InstallArgs a proper data type with documented fields or just get @@ -247,7 +261,7 @@ , RepoContext , Compiler , Platform - , ProgramConfiguration + , ProgramDb , UseSandbox , Maybe SandboxPackageInfo , GlobalFlags @@ -260,13 +274,16 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext makeInstallContext verbosity - (packageDBs, repoCtxt, comp, _, conf,_,_, - globalFlags, _, configExFlags, _, _) mUserTargets = do + (packageDBs, repoCtxt, comp, _, progdb,_,_, + globalFlags, _, configExFlags, installFlags, _) mUserTargets = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf - sourcePkgDb <- getSourcePackages verbosity repoCtxt - pkgConfigDb <- readPkgConfigDb verbosity conf + let idxState = fromFlagOrDefault IndexStateHead $ + installIndexState installFlags + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState + pkgConfigDb <- readPkgConfigDb verbosity progdb + checkConfigExFlags verbosity installedPkgIndex (packageIndex sourcePkgDb) configExFlags transport <- repoContextGetTransport repoCtxt @@ -294,7 +311,7 @@ -- | Make an install plan given install context and install arguments. makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> IO (Progress String String InstallPlan) + -> IO (Progress String String SolverInstallPlan) makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags, @@ -305,34 +322,37 @@ solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - return $ planPackages comp platform mSandboxPkgInfo solver - configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers + return $ planPackages verbosity comp platform mSandboxPkgInfo solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext - -> InstallPlan + -> SolverInstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, _, _, installFlags, _) + args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _) (installedPkgIndex, sourcePkgDb, _, - userTargets, pkgSpecifiers, _) installPlan = do + userTargets, pkgSpecifiers, _) installPlan0 = do + checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb installFlags pkgSpecifiers unless (dryRun || nothingToInstall) $ do - installPlan' <- performInstallations verbosity - args installedPkgIndex installPlan - postInstallActions verbosity args userTargets installPlan' + buildOutcomes <- performInstallations verbosity + args installedPkgIndex installPlan + postInstallActions verbosity args userTargets installPlan buildOutcomes where + installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 dryRun = fromFlag (installDryRun installFlags) - nothingToInstall = null (InstallPlan.ready installPlan) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ -planPackages :: Compiler +planPackages :: Verbosity + -> Compiler -> Platform -> Maybe SandboxPackageInfo -> Solver @@ -342,9 +362,9 @@ -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb - -> [PackageSpecifier SourcePackage] - -> Progress String String InstallPlan -planPackages comp platform mSandboxPkgInfo solver + -> [PackageSpecifier UnresolvedSourcePackage] + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = @@ -365,15 +385,22 @@ . setReorderGoals reorderGoals + . setCountConflicts countConflicts + . setAvoidReinstalls avoidReinstalls . setShadowPkgs shadowPkgs . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + . setPreferenceDefault (if upgradeDeps then PreferAllLatest else PreferLatestForSelected) + . removeLowerBounds allowOlder . removeUpperBounds allowNewer . addPreferences @@ -389,16 +416,18 @@ . addConstraints --FIXME: this just applies all flags to all targets which -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraintFlags - (pkgSpecifierTarget pkgSpecifier) flags + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | let flags = configConfigurationsFlags configFlags , not (null flags) , pkgSpecifier <- pkgSpecifiers ] . addConstraints - [ let pc = PackageConstraintStanzas - (pkgSpecifierTarget pkgSpecifier) stanzas + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | pkgSpecifier <- pkgSpecifiers ] @@ -406,6 +435,10 @@ . (if reinstall then reinstallTargets else id) + -- Don't solve for executables, the legacy install codepath + -- doesn't understand how to install them + . setSolveExecutables (SolveExecutables False) + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers @@ -417,28 +450,33 @@ reinstall = fromFlag (installOverrideReinstall installFlags) || fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) + countConflicts = fromFlag (installCountConflicts installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) shadowPkgs = fromFlag (installShadowPkgs installFlags) strongFlags = fromFlag (installStrongFlags installFlags) maxBackjumps = fromFlag (installMaxBackjumps installFlags) + allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) - allowNewer = fromMaybe AllowNewerNone (configAllowNewer configFlags) + allowOlder = fromMaybe (AllowOlder RelaxDepsNone) + (configAllowOlder configFlags) + allowNewer = fromMaybe (AllowNewer RelaxDepsNone) + (configAllowNewer configFlags) -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg => [PackageSpecifier targetpkg] - -> InstallPlan - -> Progress String String InstallPlan + -> SolverInstallPlan + -> Progress String String SolverInstallPlan pruneInstallPlan pkgSpecifiers = -- TODO: this is a general feature and should be moved to D.C.Dependency -- Also, the InstallPlan.remove should return info more precise to the -- problem, rather than the very general PlanProblem type. either (Fail . explain) Done - . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) + . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) where - explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String + explain :: [SolverInstallPlan.SolverPlanProblem] -> String explain problems = "Cannot select only the dependencies (as requested by the " ++ "'--only-dependencies' flag), " @@ -450,7 +488,7 @@ where pkgids = nub [ depid - | InstallPlan.PackageMissingDeps _ depids <- problems + | SolverInstallPlan.PackageMissingDeps _ depids <- problems , depid <- depids , packageName depid `elem` targetnames ] @@ -467,7 +505,7 @@ -> InstallPlan -> SourcePackageDb -> InstallFlags - -> [PackageSpecifier SourcePackage] + -> [PackageSpecifier UnresolvedSourcePackage] -> IO () checkPrintPlan verbosity installed installPlan sourcePkgDb installFlags pkgSpecifiers = do @@ -486,9 +524,15 @@ : map (display . packageId) preExistingTargets ++ ["Use --reinstall if you want to reinstall anyway."] - let lPlan = linearizeInstallPlan installed installPlan + let lPlan = + [ (pkg, status) + | pkg <- InstallPlan.executionOrder installPlan + , let status = packageStatus installed pkg ] -- Are any packages classified as reinstalls? - let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan + let reinstalledPkgs = + [ ipkg + | (_pkg, status) <- lPlan + , ipkg <- extractReinstalls status ] -- Packages that are already broken. let oldBrokenPkgs = map Installed.installedUnitId @@ -521,9 +565,9 @@ when containsReinstalls $ do if breaksPkgs then do - (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $ + (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ "The following packages are likely to be broken by the reinstalls:" - : map (display . Installed.sourcePackageId) newBrokenPkgs + : map (display . mungedId) newBrokenPkgs ++ if overrideReinstall then if dryRun then [] else ["Continuing even though " ++ @@ -537,54 +581,28 @@ -- are already fetched. let offline = fromFlagOrDefault False (installOfflineMode installFlags) when offline $ do - let pkgs = [ sourcePkg - | InstallPlan.Configured (ConfiguredPackage sourcePkg _ _ _) - <- InstallPlan.toList installPlan ] + let pkgs = [ confPkgSource cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ] notFetched <- fmap (map packageInfoId) . filterM (fmap isNothing . checkFetched . packageSource) $ pkgs unless (null notFetched) $ - die $ "Can't download packages in offline mode. " + die' verbosity $ "Can't download packages in offline mode. " ++ "Must download the following packages to proceed:\n" ++ intercalate ", " (map display notFetched) ++ "\nTry using 'cabal fetch'." where - nothingToInstall = null (InstallPlan.ready installPlan) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) dryRun = fromFlag (installDryRun installFlags) overrideReinstall = fromFlag (installOverrideReinstall installFlags) ---TODO: this type is too specific -linearizeInstallPlan :: InstalledPackageIndex - -> InstallPlan - -> [(ReadyPackage, PackageStatus)] -linearizeInstallPlan installedPkgIndex plan = - unfoldr next plan - where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just ((pkg, status), plan'') - where - pkgid = installedUnitId pkg - status = packageStatus installedPkgIndex pkg - ipkg = Installed.emptyInstalledPackageInfo { - Installed.sourcePackageId = packageId pkg, - Installed.installedUnitId = pkgid - } - plan'' = InstallPlan.completed pkgid (Just ipkg) - (BuildOk DocsNotTried TestsNotTried (Just ipkg)) - (InstallPlan.processing [pkg] plan') - --FIXME: This is a bit of a hack, - -- pretending that each package is installed - -- It's doubly a hack because the installed package ID - -- didn't get updated... - data PackageStatus = NewPackage | NewVersion [Version] | Reinstall [UnitId] [PackageChange] -type PackageChange = MergeResult PackageIdentifier PackageIdentifier +type PackageChange = MergeResult MungedPackageId MungedPackageId extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids @@ -597,8 +615,8 @@ case PackageIndex.lookupPackageName installedPkgIndex (packageName cpkg) of [] -> NewPackage - ps -> case filter ((== packageId cpkg) - . Installed.sourcePackageId) (concatMap snd ps) of + ps -> case filter ((== mungedId cpkg) + . mungedId) (concatMap snd ps) of [] -> NewVersion (map fst ps) pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) (changes pkg cpkg) @@ -607,20 +625,20 @@ changes :: Installed.InstalledPackageInfo -> ReadyPackage - -> [MergeResult PackageIdentifier PackageIdentifier] - changes pkg pkg' = filter changed $ - mergeBy (comparing packageName) + -> [PackageChange] + changes pkg (ReadyPackage pkg') = filter changed $ + mergeBy (comparing mungedName) -- deps of installed pkg (resolveInstalledIds $ Installed.depends pkg) -- deps of configured pkg (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) -- convert to source pkg ids via index - resolveInstalledIds :: [UnitId] -> [PackageIdentifier] + resolveInstalledIds :: [UnitId] -> [MungedPackageId] resolveInstalledIds = nub . sort - . map Installed.sourcePackageId + . map mungedId . catMaybes . map (PackageIndex.lookupUnitId installedPkgIndex) @@ -635,7 +653,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of [] -> return () pkgs - | verbosity >= Verbosity.verbose -> putStr $ unlines $ + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ ("In order, the following " ++ wouldWill ++ " be installed:") : map showPkgAndReason pkgs | otherwise -> notice verbosity $ unlines $ @@ -649,10 +667,10 @@ showPkg (pkg, _) = display (packageId pkg) ++ showLatest (pkg) - showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') ++ + showPkgAndReason (ReadyPackage pkg', pr) = display (packageId pkg') ++ showLatest pkg' ++ showFlagAssignment (nonDefaultFlags pkg') ++ - showStanzas (stanzas pkg') ++ + showStanzas (confPkgStanzas pkg') ++ showDep pkg' ++ case pr of NewPackage -> " (new package)" @@ -680,30 +698,23 @@ toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) - nonDefaultFlags :: ConfiguredPackage -> FlagAssignment - nonDefaultFlags (ConfiguredPackage spkg fa _ _) = + nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment + nonDefaultFlags cpkg = let defaultAssignment = toFlagAssignment - (genPackageFlags (Source.packageDescription spkg)) - in fa \\ defaultAssignment - - stanzas :: ConfiguredPackage -> [OptionalStanza] - stanzas (ConfiguredPackage _ _ sts _) = sts + (genPackageFlags (SourcePackage.packageDescription $ + confPkgSource cpkg)) + in confPkgFlags cpkg \\ defaultAssignment showStanzas :: [OptionalStanza] -> String - showStanzas = concatMap ((' ' :) . showStanza) - showStanza TestStanzas = "*test" - showStanza BenchStanzas = "*bench" + showStanzas = concatMap ((" *" ++) . showStanza) showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) - showFlagValue (f, True) = '+' : showFlagName f - showFlagValue (f, False) = '-' : showFlagName f - showFlagName (FlagName f) = f change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " - ++ display (packageVersion pkgid') + ++ display (mungedVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added" showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps @@ -711,9 +722,10 @@ | otherwise = "" revDepGraphEdges :: [(PackageId, PackageId)] - revDepGraphEdges = [ (rpid, packageId pkg) - | (pkg@(ReadyPackage _ deps), _) <- plan - , rpid <- Installed.sourcePackageId <$> CD.flatDeps deps ] + revDepGraphEdges = [ (rpid, packageId cpkg) + | (ReadyPackage cpkg, _) <- plan + , ConfiguredId rpid (Just PackageDescription.CLibName) _ + <- CD.flatDeps (confPkgDeps cpkg) ] revDeps :: Map.Map PackageId [PackageId] revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) @@ -776,8 +788,8 @@ theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackageConstraintVersion name' version] - | name == name' -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where @@ -804,11 +816,12 @@ -> InstallArgs -> [UserTarget] -> InstallPlan + -> BuildOutcomes -> IO () postInstallActions verbosity - (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo + (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo ,globalFlags, configFlags, _, installFlags, _) - targets installPlan = do + targets installPlan buildOutcomes = do unless oneShot $ World.insert verbosity worldFile @@ -817,7 +830,7 @@ | UserTargetNamed dep <- targets ] let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) - installPlan + installPlan buildOutcomes BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports @@ -827,15 +840,16 @@ when (reportingLevel == DetailedReports) $ storeDetailedBuildReports verbosity logsDir buildReports - regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox - configFlags installFlags installPlan + regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox + configFlags installFlags buildOutcomes - symlinkBinaries verbosity platform comp configFlags installFlags installPlan + symlinkBinaries verbosity platform comp configFlags installFlags + installPlan buildOutcomes - printBuildFailures installPlan + printBuildFailures verbosity buildOutcomes - updateSandboxTimestampsFile useSandbox mSandboxPkgInfo - comp platform installPlan + updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo + comp platform installPlan buildOutcomes where reportingLevel = fromFlag (installBuildReports installFlags) @@ -881,14 +895,14 @@ -> [PackageDB] -> Compiler -> Platform - -> ProgramConfiguration + -> ProgramDb -> UseSandbox -> ConfigFlags -> InstallFlags - -> InstallPlan + -> BuildOutcomes -> IO () -regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox - configFlags installFlags installPlan +regenerateHaddockIndex verbosity packageDBs comp platform progdb useSandbox + configFlags installFlags buildOutcomes | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do defaultDirs <- InstallDirs.defaultInstallDirs @@ -902,8 +916,8 @@ "Updating documentation index " ++ indexFile --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf - Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb + Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile | otherwise = return () where @@ -916,14 +930,14 @@ -- #1337), we don't do it for global installs or special cases where we're -- installing into a specific db. shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall) - && someDocsWereInstalled installPlan + && someDocsWereInstalled buildOutcomes where - someDocsWereInstalled = any installedDocs . InstallPlan.toList + someDocsWereInstalled = any installedDocs . Map.elems + installedDocs (Right (BuildResult DocsOk _ _)) = True + installedDocs _ = False + normalUserInstall = (UserPackageDB `elem` packageDBs) && all (not . isSpecificPackageDB) packageDBs - - installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True - installedDocs _ = False isSpecificPackageDB (SpecificPackageDB _) = True isSpecificPackageDB _ = False @@ -945,24 +959,26 @@ -> ConfigFlags -> InstallFlags -> InstallPlan + -> BuildOutcomes -> IO () -symlinkBinaries verbosity platform comp configFlags installFlags plan = do +symlinkBinaries verbosity platform comp configFlags installFlags + plan buildOutcomes = do failed <- InstallSymlink.symlinkBinaries platform comp configFlags installFlags - plan + plan buildOutcomes case failed of [] -> return () [(_, exe, path)] -> warn verbosity $ "could not create a symlink in " ++ bindir ++ " for " - ++ exe ++ " because the file exists there already but is not " + ++ display exe ++ " because the file exists there already but is not " ++ "managed by cabal. You can create a symlink for this executable " ++ "manually if you wish. The executable file has been installed at " ++ path exes -> warn verbosity $ "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ intercalate ", " [ display exe | (_, exe, _) <- exes ] ++ " because the files exist there already and are not " ++ "managed by cabal. You can create symlinks for these executables " ++ "manually if you wish. The executable files have been installed at " @@ -971,16 +987,15 @@ bindir = fromFlag (installSymlinkBinDir installFlags) -printBuildFailures :: InstallPlan - -> IO () -printBuildFailures plan = - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of +printBuildFailures :: Verbosity -> BuildOutcomes -> IO () +printBuildFailures verbosity buildOutcomes = + case [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] of [] -> return () - failed -> die . unlines + failed -> die' verbosity . unlines $ "Error: some packages failed to install:" - : [ display (packageId pkg) ++ printFailureReason reason - | (pkg, reason) <- failed ] + : [ display pkgid ++ printFailureReason reason + | (pkgid, reason) <- failed ] where printFailureReason reason = case reason of DependentFailed pkgid -> " depends on " ++ display pkgid @@ -1015,31 +1030,35 @@ -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. -updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo +updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan + -> BuildOutcomes -> IO () -updateSandboxTimestampsFile (UseSandbox sandboxDir) +updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) - comp platform installPlan = - withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do - let allInstalled = [ pkg | InstallPlan.Installed pkg _ _ - <- InstallPlan.toList installPlan ] - allSrcPkgs = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _ - <- allInstalled ] + comp platform installPlan buildOutcomes = + withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do + let allInstalled = [ pkg + | InstallPlan.Configured pkg + <- InstallPlan.toList installPlan + , case InstallPlan.lookupBuildOutcome pkg buildOutcomes of + Just (Right _success) -> True + _ -> False + ] + allSrcPkgs = [ confPkgSource cpkg | cpkg <- allInstalled ] allPaths = [ pth | LocalUnpackedPackage pth <- map packageSource allSrcPkgs] allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ = return () +updateSandboxTimestampsFile _ _ _ _ _ _ _ = return () -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------ data InstallMisc = InstallMisc { - rootCmd :: Maybe FilePath, libVersion :: Maybe Version } @@ -1051,9 +1070,9 @@ -> InstallArgs -> InstalledPackageIndex -> InstallPlan - -> IO InstallPlan + -> IO BuildOutcomes performInstallations verbosity - (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _, + (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do @@ -1062,26 +1081,26 @@ when parallelInstall $ notice verbosity $ "Notice: installing into a sandbox located at " ++ sandboxDir + info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "." - jobControl <- if parallelInstall then newParallelJobControl + jobControl <- if parallelInstall then newParallelJobControl numJobs else newSerialJobControl - buildLimit <- newJobLimit numJobs fetchLimit <- newJobLimit (min numJobs numFetchJobs) installLock <- newLock -- serialise installation cacheLock <- newLock -- serialise access to setup exe cache - executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg -> + executeInstallPlan verbosity jobControl keepGoing useLogFile + installPlan $ \rpkg -> installReadyPackage platform cinfo configFlags rpkg $ \configFlags' src pkg pkgoverride -> fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' -> - installLocalPackage verbosity buildLimit - (packageId pkg) src' distPref $ \mpath -> - installUnpackedPackage verbosity buildLimit installLock numJobs + installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath -> + installUnpackedPackage verbosity installLock numJobs (setupScriptOptions installedPkgIndex cacheLock rpkg) - miscOptions configFlags' - installFlags haddockFlags - cinfo platform pkg rpkg pkgoverride mpath useLogFile + configFlags' + installFlags haddockFlags comp progdb + platform pkg rpkg pkgoverride mpath useLogFile where cinfo = compilerInfo comp @@ -1089,6 +1108,7 @@ numJobs = determineNumJobs (installNumJobs installFlags) numFetchJobs = 2 parallelInstall = numJobs >= 2 + keepGoing = fromFlag (installKeepGoing installFlags) distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (configDistPref configFlags) @@ -1097,7 +1117,7 @@ packageDBs comp platform - conf + progdb distPref (chooseCabalVersion configFlags (libVersion miscOptions)) (Just lock) @@ -1114,7 +1134,8 @@ logFileTemplate where installLogFile' = flagToMaybe $ installLogFile installFlags - defaultTemplate = toPathTemplate $ logsDir "$pkgid" <.> "log" + defaultTemplate = toPathTemplate $ + logsDir "$compiler" "$libname" <.> "log" -- If the user has specified --remote-build-reporting=detailed, use the -- default log file location. If the --build-log option is set, use the @@ -1146,82 +1167,38 @@ | otherwise = False substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath - substLogFileName template pkg ipid = fromPathTemplate + substLogFileName template pkg uid = fromPathTemplate . substPathTemplate env $ template - where env = initialPathTemplateEnv (packageId pkg) - ipid - (compilerInfo comp) platform + where env = initialPathTemplateEnv (packageId pkg) uid + (compilerInfo comp) platform miscOptions = InstallMisc { - rootCmd = if fromFlag (configUserInstall configFlags) - || (isUseSandbox useSandbox) - then Nothing -- ignore --root-cmd if --user - -- or working inside a sandbox. - else flagToMaybe (installRootCmd installFlags), libVersion = flagToMaybe (configCabalVersion configExFlags) } executeInstallPlan :: Verbosity - -> Compiler - -> JobControl IO (PackageId, UnitId, BuildResult) + -> JobControl IO (UnitId, BuildOutcome) + -> Bool -> UseLogFile -> InstallPlan - -> (ReadyPackage -> IO BuildResult) - -> IO InstallPlan -executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg = - tryNewTasks 0 plan0 - where - tryNewTasks taskCount plan = do - case InstallPlan.ready plan of - [] | taskCount == 0 -> return plan - | otherwise -> waitForTasks taskCount plan - pkgs -> do - sequence_ - [ do info verbosity $ "Ready to install " ++ display pkgid - spawnJob jobCtl $ do - buildResult <- installPkg pkg - let ipid = case buildResult of - Right (BuildOk _ _ (Just ipi)) -> - Installed.installedUnitId ipi - _ -> mkUnitId (display (packageId pkg)) - return (packageId pkg, ipid, buildResult) - | pkg <- pkgs - , let pkgid = packageId pkg ] - - let taskCount' = taskCount + length pkgs - plan' = InstallPlan.processing pkgs plan - waitForTasks taskCount' plan' - - waitForTasks taskCount plan = do - info verbosity $ "Waiting for install task to finish..." - (pkgid, ipid, buildResult) <- collectJob jobCtl - printBuildResult pkgid ipid buildResult - let taskCount' = taskCount-1 - plan' = updatePlan pkgid buildResult plan - tryNewTasks taskCount' plan' - - updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan - -> InstallPlan - updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) = - InstallPlan.completed (Source.fakeUnitId pkgid) - mipkg buildSuccess + -> (ReadyPackage -> IO BuildOutcome) + -> IO BuildOutcomes +executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = + InstallPlan.execute + jobCtl keepGoing depsFailure plan0 $ \pkg -> do + buildOutcome <- installPkg pkg + printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome + return buildOutcome - updatePlan pkgid (Left buildFailure) = - InstallPlan.failed (Source.fakeUnitId pkgid) - buildFailure depsFailure - where - depsFailure = DependentFailed pkgid - -- So this first pkgid failed for whatever reason (buildFailure). - -- All the other packages that depended on this pkgid, which we - -- now cannot build, we mark as failing due to 'DependentFailed' - -- which kind of means it was not their fault. + where + depsFailure = DependentFailed . packageId -- Print build log if something went wrong, and 'Installed $PKGID' -- otherwise. - printBuildResult :: PackageId -> UnitId -> BuildResult -> IO () - printBuildResult pkgid ipid buildResult = case buildResult of + printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () + printBuildResult pkgid uid buildOutcome = case buildOutcome of (Right _) -> notice verbosity $ "Installed " ++ display pkgid (Left _) -> do notice verbosity $ "Failed to install " ++ display pkgid @@ -1229,7 +1206,7 @@ case useLogFile of Nothing -> return () Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid ipid + let logName = mkLogFileName pkgid uid putStr $ "Build log ( " ++ logName ++ " ):\n" printFile logName @@ -1247,46 +1224,47 @@ installReadyPackage :: Platform -> CompilerInfo -> ConfigFlags -> ReadyPackage - -> (ConfigFlags -> PackageLocation (Maybe FilePath) + -> (ConfigFlags -> UnresolvedPkgLoc -> PackageDescription -> PackageDescriptionOverride -> a) -> a installReadyPackage platform cinfo configFlags - (ReadyPackage (ConfiguredPackage + (ReadyPackage (ConfiguredPackage ipid (SourcePackage _ gpkg source pkgoverride) - flags stanzas _) - deps) + flags stanzas deps)) installPkg = installPkg configFlags { + configIPID = toFlag (display ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise deps. -- In the end only one set gets passed to Setup.hs configure, depending on -- the Cabal version we are talking to. - configConstraints = [ thisPackageVersion (packageId deppkg) - | deppkg <- CD.nonSetupDeps deps ], - configDependencies = [ (packageName (Installed.sourcePackageId deppkg), - Installed.installedUnitId deppkg) - | deppkg <- CD.nonSetupDeps deps ], + configConstraints = [ thisPackageVersion srcid + | ConfiguredId srcid (Just PackageDescription.CLibName) _ipid + <- CD.nonSetupDeps deps ], + configDependencies = [ (packageName srcid, dep_ipid) + | ConfiguredId srcid (Just PackageDescription.CLibName) dep_ipid + <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configBenchmarks = toFlag False, configTests = toFlag (TestStanzas `elem` stanzas) } source pkg pkgoverride where - pkg = case finalizePackageDescription flags + pkg = case finalizePD flags (enableStanzas stanzas) (const True) - platform cinfo [] (enableStanzas stanzas gpkg) of - Left _ -> error "finalizePackageDescription ReadyPackage failed" + platform cinfo [] gpkg of + Left _ -> error "finalizePD ReadyPackage failed" Right (desc, _) -> desc fetchSourcePackage :: Verbosity -> RepoContext -> JobLimit - -> PackageLocation (Maybe FilePath) - -> (PackageLocation FilePath -> IO BuildResult) - -> IO BuildResult + -> UnresolvedPkgLoc + -> (ResolvedPkgLoc -> IO BuildOutcome) + -> IO BuildOutcome fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do fetched <- checkFetched src case fetched of @@ -1299,11 +1277,10 @@ installLocalPackage :: Verbosity - -> JobLimit - -> PackageIdentifier -> PackageLocation FilePath -> FilePath - -> (Maybe FilePath -> IO BuildResult) - -> IO BuildResult -installLocalPackage verbosity jobLimit pkgid location distPref installPkg = + -> PackageIdentifier -> ResolvedPkgLoc -> FilePath + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalPackage verbosity pkgid location distPref installPkg = case location of @@ -1311,25 +1288,24 @@ installPkg (Just dir) LocalTarballPackage tarballPath -> - installLocalTarballPackage verbosity jobLimit + installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg RemoteTarballPackage _ tarballPath -> - installLocalTarballPackage verbosity jobLimit + installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg RepoTarballPackage _ _ tarballPath -> - installLocalTarballPackage verbosity jobLimit + installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg installLocalTarballPackage :: Verbosity - -> JobLimit -> PackageIdentifier -> FilePath -> FilePath - -> (Maybe FilePath -> IO BuildResult) - -> IO BuildResult -installLocalTarballPackage verbosity jobLimit pkgid + -> (Maybe FilePath -> IO BuildOutcome) + -> IO BuildOutcome +installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> @@ -1338,15 +1314,13 @@ absUnpackedPath = tmpDirPath relUnpackedPath descFilePath = absUnpackedPath display (packageName pkgid) <.> "cabal" - withJobLimit jobLimit $ do - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath - maybeRenameDistDir absUnpackedPath - + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + when (not exists) $ + die' verbosity $ "Package .cabal file not found: " ++ show descFilePath + maybeRenameDistDir absUnpackedPath installPkg (Just absUnpackedPath) where @@ -1379,27 +1353,25 @@ installUnpackedPackage :: Verbosity - -> JobLimit -> Lock -> Int -> SetupScriptOptions - -> InstallMisc -> ConfigFlags -> InstallFlags -> HaddockFlags - -> CompilerInfo + -> Compiler + -> ProgramDb -> Platform -> PackageDescription -> ReadyPackage -> PackageDescriptionOverride -> Maybe FilePath -- ^ Directory to change to before starting the installation. -> UseLogFile -- ^ File to log output to (if any) - -> IO BuildResult -installUnpackedPackage verbosity buildLimit installLock numJobs - scriptOptions miscOptions - configFlags installFlags haddockFlags - cinfo platform pkg rpkg pkgoverride workingDir useLogFile = do - + -> IO BuildOutcome +installUnpackedPackage verbosity installLock numJobs + scriptOptions + configFlags installFlags haddockFlags comp progdb + platform pkg rpkg pkgoverride workingDir useLogFile = do -- Override the .cabal file if necessary case pkgoverride of Nothing -> return () @@ -1411,15 +1383,9 @@ ++ " with the latest revision from the index." writeFileAtomic descFilePath pkgtxt - -- Compute the IPID - let flags (ReadyPackage (ConfiguredPackage _ x _ _) _) = x - cid = Configure.computeComponentId (PackageDescription.package pkg) CLibName - (map (\(SimpleUnitId cid0) -> cid0) (CD.libraryDeps (depends rpkg))) (flags rpkg) - ipid = SimpleUnitId cid - -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if -- the setup script was compiled against an old version of the Cabal lib). - configFlags' <- addDefaultInstallDirs ipid configFlags + configFlags' <- addDefaultInstallDirs configFlags -- Filter out flags not supported by the old versions of the Cabal lib. let configureFlags :: Version -> ConfigFlags configureFlags = filterConfigureFlags configFlags' { @@ -1427,11 +1393,11 @@ } -- Path to the optional log file. - mLogPath <- maybeLogPath ipid + mLogPath <- maybeLogPath - logDirChange (maybe putStr appendFile mLogPath) workingDir $ do + logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do -- Configure phase - onFailure ConfigureFailed $ withJobLimit buildLimit $ do + onFailure ConfigureFailed $ do when (numJobs > 1) $ notice verbosity $ "Configuring " ++ display pkgid ++ "..." setup configureCommand configureFlags mLogPath @@ -1460,23 +1426,32 @@ -- Install phase onFailure InstallFailed $ criticalSection installLock $ do - -- Capture installed package configuration file - maybePkgConf <- maybeGenPkgConf mLogPath - -- Actual installation - withWin32SelfUpgrade verbosity ipid configFlags + withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg $ do - case rootCmd miscOptions of - (Just cmd) -> reexec cmd - Nothing -> do - setup Cabal.copyCommand copyFlags mLogPath - when shouldRegister $ do - setup Cabal.registerCommand registerFlags mLogPath - return (Right (BuildOk docsResult testsResult maybePkgConf)) + setup Cabal.copyCommand copyFlags mLogPath + -- Capture installed package configuration file, so that + -- it can be incorporated into the final InstallPlan + ipkgs <- genPkgConfs mLogPath + let ipkgs' = case ipkgs of + [ipkg] -> [ipkg { Installed.installedUnitId = uid }] + _ -> ipkgs + let packageDBs = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags)) + (configPackageDBs configFlags) + forM_ ipkgs' $ \ipkg' -> + registerPackage verbosity comp progdb + packageDBs ipkg' + defaultRegisterOptions + + return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) + where pkgid = packageId pkg - buildCommand' = buildCommand defaultProgramConfiguration + uid = installedUnitId rpkg + cinfo = compilerInfo comp + buildCommand' = buildCommand progdb buildFlags _ = emptyBuildFlags { buildDistPref = configDistPref configFlags, buildVerbosity = toFlag verbosity' @@ -1504,8 +1479,8 @@ verbosity' = maybe verbosity snd useLogFile tempTemplate name = name ++ "-" ++ display pkgid - addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags - addDefaultInstallDirs ipid configFlags' = do + addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags + addDefaultInstallDirs configFlags' = do defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False return $ configFlags' { configInstallDirs = fmap Cabal.Flag . @@ -1515,41 +1490,54 @@ } where CompilerId flavor _ = compilerInfoId cinfo - env = initialPathTemplateEnv pkgid ipid cinfo platform + env = initialPathTemplateEnv pkgid uid cinfo platform userInstall = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags') - maybeGenPkgConf :: Maybe FilePath - -> IO (Maybe Installed.InstalledPackageInfo) - maybeGenPkgConf mLogPath = + genPkgConfs :: Maybe FilePath + -> IO [Installed.InstalledPackageInfo] + genPkgConfs mLogPath = if shouldRegister then do tmp <- getTemporaryDirectory - withTempFile tmp (tempTemplate "pkgConf") $ \pkgConfFile handle -> do - hClose handle - let registerFlags' version = (registerFlags version) { - Cabal.regGenPkgConf = toFlag (Just pkgConfFile) + withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do + let pkgConfDest = dir "pkgConf" + registerFlags' version = (registerFlags version) { + Cabal.regGenPkgConf = toFlag (Just pkgConfDest) } setup Cabal.registerCommand registerFlags' mLogPath - withUTF8FileContents pkgConfFile $ \pkgConfText -> - case Installed.parseInstalledPackageInfo pkgConfText of - Installed.ParseFailed perror -> pkgConfParseFailed perror - Installed.ParseOk warns pkgConf -> do - unless (null warns) $ - warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) - return (Just pkgConf) - else return Nothing + is_dir <- doesDirectoryExist pkgConfDest + let notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + if is_dir + -- Sort so that each prefix of the package + -- configurations is well formed + then mapM (readPkgConf pkgConfDest) . sort . filter notHidden + =<< getDirectoryContents pkgConfDest + else fmap (:[]) $ readPkgConf "." pkgConfDest + else return [] + readPkgConf :: FilePath -> FilePath + -> IO Installed.InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = + (withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfText -> + case Installed.parseInstalledPackageInfo pkgConfText of + Installed.ParseFailed perror -> pkgConfParseFailed perror + Installed.ParseOk warns pkgConf -> do + unless (null warns) $ + warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) + return pkgConf) + pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror - maybeLogPath :: UnitId -> IO (Maybe FilePath) - maybeLogPath ipid = + maybeLogPath :: IO (Maybe FilePath) + maybeLogPath = case useLogFile of Nothing -> return Nothing Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) ipid + let logFileName = mkLogFileName (packageId pkg) uid logDir = takeDirectory logFileName unless (null logDir) $ createDirectoryIfMissing True logDir logFileExists <- doesFileExist logFileName @@ -1567,28 +1555,16 @@ (Just pkg) cmd flags []) - reexec cmd = do - -- look for our own executable file and re-exec ourselves using a helper - -- program like sudo to elevate privileges: - self <- getExecutablePath - weExist <- doesFileExist self - if weExist - then inDir workingDir $ - rawSystemExit verbosity cmd - [self, "install", "--only" - ,"--verbose=" ++ showForCabal verbosity] - else die $ "Unable to find cabal executable at: " ++ self - -- helper -onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult +onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome onFailure result action = action `catches` [ Handler $ \ioe -> handler (ioe :: IOException) , Handler $ \exit -> handler (exit :: ExitCode) ] where - handler :: Exception e => e -> IO BuildResult + handler :: Exception e => e -> IO BuildOutcome handler = return . Left . result . toException @@ -1604,7 +1580,7 @@ -> PackageDescription -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do +withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs compFlavor @@ -1622,7 +1598,7 @@ [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension | exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix prefix = substTemplate prefixTemplate suffix = substTemplate suffixTemplate ] where @@ -1632,10 +1608,10 @@ templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid ipid + pkgid uid cinfo InstallDirs.NoCopyDest platform templateDirs substTemplate = InstallDirs.fromPathTemplate . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid ipid + where env = InstallDirs.initialPathTemplateEnv pkgid uid cinfo platform diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -1,788 +1,943 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- Stability : provisional --- Portability : portable --- --- Package installation plan --- ------------------------------------------------------------------------------ -module Distribution.Client.InstallPlan ( - InstallPlan, - GenericInstallPlan, - PlanPackage, - GenericPlanPackage(..), - - -- * Operations on 'InstallPlan's - new, - toList, - mapPreservingGraph, - - ready, - processing, - completed, - failed, - remove, - preexisting, - preinstalled, - - showPlanIndex, - showInstallPlan, - - -- * Checking validity of plans - valid, - closed, - consistent, - acyclic, - - -- ** Details on invalid plans - PlanProblem(..), - showPlanProblem, - problems, - - -- ** Querying the install plan - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - ) where - -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..) - , HasUnitId(..), UnitId(..) ) -import Distribution.Client.Types - ( BuildSuccess, BuildFailure - , PackageFixedDeps(..), ConfiguredPackage - , GenericReadyPackage(..), fakeUnitId ) -import Distribution.Version - ( Version ) -import Distribution.Client.ComponentDeps (ComponentDeps) -import qualified Distribution.Client.ComponentDeps as CD -import Distribution.Simple.PackageIndex - ( PackageIndex ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Client.PlanIndex - ( FakeMap ) -import qualified Distribution.Client.PlanIndex as PlanIndex -import Distribution.Text - ( display ) - -import Data.List - ( foldl', intercalate ) -import Data.Maybe - ( fromMaybe, catMaybes ) -import qualified Data.Graph as Graph -import Data.Graph (Graph) -import qualified Data.Tree as Tree -import Distribution.Compat.Binary (Binary(..)) -import GHC.Generics -import Control.Exception - ( assert ) -import qualified Data.Map as Map -import qualified Data.Traversable as T - - --- When cabal tries to install a number of packages, including all their --- dependencies it has a non-trivial problem to solve. --- --- The Problem: --- --- In general we start with a set of installed packages and a set of source --- packages. --- --- Installed packages have fixed dependencies. They have already been built and --- we know exactly what packages they were built against, including their exact --- versions. --- --- Source package have somewhat flexible dependencies. They are specified as --- version ranges, though really they're predicates. To make matters worse they --- have conditional flexible dependencies. Configuration flags can affect which --- packages are required and can place additional constraints on their --- versions. --- --- These two sets of package can and usually do overlap. There can be installed --- packages that are also available as source packages which means they could --- be re-installed if required, though there will also be packages which are --- not available as source and cannot be re-installed. Very often there will be --- extra versions available than are installed. Sometimes we may like to prefer --- installed packages over source ones or perhaps always prefer the latest --- available version whether installed or not. --- --- The goal is to calculate an installation plan that is closed, acyclic and --- consistent and where every configured package is valid. --- --- An installation plan is a set of packages that are going to be used --- together. It will consist of a mixture of installed packages and source --- packages along with their exact version dependencies. An installation plan --- is closed if for every package in the set, all of its dependencies are --- also in the set. It is consistent if for every package in the set, all --- dependencies which target that package have the same version. - --- Note that plans do not necessarily compose. You might have a valid plan for --- package A and a valid plan for package B. That does not mean the composition --- is simultaneously valid for A and B. In particular you're most likely to --- have problems with inconsistent dependencies. --- On the other hand it is true that every closed sub plan is valid. - --- | Packages in an install plan --- --- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' --- intentionally have no 'PackageInstalled' instance. `This is important: --- PackageInstalled returns only library dependencies, but for package that --- aren't yet installed we know many more kinds of dependencies (setup --- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on --- dependencies in cabal-install should consider what to do with these --- dependencies; if we give a 'PackageInstalled' instance it would be too easy --- to get this wrong (and, for instance, call graph traversal functions from --- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'. -data GenericPlanPackage ipkg srcpkg iresult ifailure - = PreExisting ipkg - | Configured srcpkg - | Processing (GenericReadyPackage srcpkg ipkg) - | Installed (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult - | Failed srcpkg ifailure - deriving (Eq, Show, Generic) - -instance (Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure) - => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure) - -type PlanPackage = GenericPlanPackage - InstalledPackageInfo ConfiguredPackage - BuildSuccess BuildFailure - -instance (Package ipkg, Package srcpkg) => - Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where - packageId (PreExisting ipkg) = packageId ipkg - packageId (Configured spkg) = packageId spkg - packageId (Processing rpkg) = packageId rpkg - packageId (Installed rpkg _ _) = packageId rpkg - packageId (Failed spkg _) = packageId spkg - -instance (PackageFixedDeps srcpkg, - PackageFixedDeps ipkg, HasUnitId ipkg) => - PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where - depends (PreExisting pkg) = depends pkg - depends (Configured pkg) = depends pkg - depends (Processing pkg) = depends pkg - depends (Installed pkg _ _) = depends pkg - depends (Failed pkg _) = depends pkg - -instance (HasUnitId ipkg, HasUnitId srcpkg) => - HasUnitId - (GenericPlanPackage ipkg srcpkg iresult ifailure) where - installedUnitId (PreExisting ipkg ) = installedUnitId ipkg - installedUnitId (Configured spkg) = installedUnitId spkg - installedUnitId (Processing rpkg) = installedUnitId rpkg - -- NB: defer to the actual installed package info in this case - installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg - installedUnitId (Installed rpkg _ _) = installedUnitId rpkg - installedUnitId (Failed spkg _) = installedUnitId spkg - - -data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan { - planIndex :: !(PlanIndex ipkg srcpkg iresult ifailure), - planFakeMap :: !FakeMap, - planIndepGoals :: !Bool, - - -- | Cached (lazily) graph - -- - -- The 'Graph' representaion works in terms of integer node ids, so we - -- have to keep mapping to and from our meaningful nodes, which of course - -- are package ids. - -- - planGraph :: Graph, - planGraphRev :: Graph, -- ^ Reverse deps, transposed - planPkgIdOf :: Graph.Vertex -> UnitId, -- ^ mapping back to package ids - planVertexOf :: UnitId -> Graph.Vertex -- ^ mapping into node ids - } - --- | Much like 'planPkgIdOf', but mapping back to full packages. -planPkgOf :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> Graph.Vertex - -> GenericPlanPackage ipkg srcpkg iresult ifailure -planPkgOf plan v = - case PackageIndex.lookupUnitId (planIndex plan) - (planPkgIdOf plan v) of - Just pkg -> pkg - Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" - - --- | 'GenericInstallPlan' specialised to most commonly used types. -type InstallPlan = GenericInstallPlan - InstalledPackageInfo ConfiguredPackage - BuildSuccess BuildFailure - -type PlanIndex ipkg srcpkg iresult ifailure = - PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure) - -invariant :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool -invariant plan = - valid (planFakeMap plan) - (planIndepGoals plan) - (planIndex plan) - --- | Smart constructor that deals with caching the 'Graph' representation. --- -mkInstallPlan :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => PlanIndex ipkg srcpkg iresult ifailure - -> FakeMap - -> Bool - -> GenericInstallPlan ipkg srcpkg iresult ifailure -mkInstallPlan index fakeMap indepGoals = - GenericInstallPlan { - planIndex = index, - planFakeMap = fakeMap, - planIndepGoals = indepGoals, - - -- lazily cache the graph stuff: - planGraph = graph, - planGraphRev = Graph.transposeG graph, - planPkgIdOf = vertexToPkgId, - planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex - } - where - (graph, vertexToPkgId, pkgIdToVertex) = - PlanIndex.dependencyGraph fakeMap index - noSuchPkgId = internalError "package is not in the graph" - -internalError :: String -> a -internalError msg = error $ "InstallPlan: internal error: " ++ msg - -instance (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg, - Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure) - => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where - put GenericInstallPlan { - planIndex = index, - planFakeMap = fakeMap, - planIndepGoals = indepGoals - } = put (index, fakeMap, indepGoals) - - get = do - (index, fakeMap, indepGoals) <- get - return $! mkInstallPlan index fakeMap indepGoals - -showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg) - => PlanIndex ipkg srcpkg iresult ifailure -> String -showPlanIndex index = - intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index)) - where showPlanPackage p = - showPlanPackageTag p ++ " " - ++ display (packageId p) ++ " (" - ++ display (installedUnitId p) ++ ")" - -showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure -> String -showInstallPlan plan = - showPlanIndex (planIndex plan) ++ "\n" ++ - "fake map:\n " ++ - intercalate "\n " (map showKV (Map.toList (planFakeMap plan))) - where showKV (k,v) = display k ++ " -> " ++ display v - -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Processing _) = "Processing" -showPlanPackageTag (Installed _ _ _) = "Installed" -showPlanPackageTag (Failed _ _) = "Failed" - --- | Build an installation plan from a valid set of resolved packages. --- -new :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => Bool - -> PlanIndex ipkg srcpkg iresult ifailure - -> Either [PlanProblem ipkg srcpkg iresult ifailure] - (GenericInstallPlan ipkg srcpkg iresult ifailure) -new indepGoals index = - -- NB: Need to pre-initialize the fake-map with pre-existing - -- packages - let isPreExisting (PreExisting _) = True - isPreExisting _ = False - fakeMap = Map.fromList - . map (\p -> (fakeUnitId (packageId p) - ,installedUnitId p)) - . filter isPreExisting - $ PackageIndex.allPackages index in - case problems fakeMap indepGoals index of - [] -> Right (mkInstallPlan index fakeMap indepGoals) - probs -> Left probs - -toList :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -toList = PackageIndex.allPackages . planIndex - --- | Remove packages from the install plan. This will result in an --- error if there are remaining packages that depend on any matching --- package. This is primarily useful for obtaining an install plan for --- the dependencies of a package or set of packages without actually --- installing the package itself, as when doing development. --- -remove :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool) - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> Either [PlanProblem ipkg srcpkg iresult ifailure] - (GenericInstallPlan ipkg srcpkg iresult ifailure) -remove shouldRemove plan = - new (planIndepGoals plan) newIndex - where - newIndex = PackageIndex.fromList $ - filter (not . shouldRemove) (toList plan) - --- | The packages that are ready to be installed. That is they are in the --- configured state and have all their dependencies installed already. --- The plan is complete if the result is @[]@. --- -ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericReadyPackage srcpkg ipkg] -ready plan = assert check readyPackages - where - check = if null readyPackages && null processingPackages - then null configuredPackages - else True - configuredPackages = [ pkg | Configured pkg <- toList plan ] - processingPackages = [ pkg | Processing pkg <- toList plan] - - readyPackages :: [GenericReadyPackage srcpkg ipkg] - readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages) - -lookupReadyPackage :: forall ipkg srcpkg iresult ifailure. - PackageFixedDeps srcpkg - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> srcpkg - -> Maybe (GenericReadyPackage srcpkg ipkg) -lookupReadyPackage plan pkg = do - deps <- hasAllInstalledDeps pkg - return (ReadyPackage pkg deps) - where - - hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg]) - hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends - - isInstalledDep :: UnitId -> Maybe ipkg - isInstalledDep pkgid = - -- NB: Need to check if the ID has been updated in planFakeMap, in which - -- case we might be dealing with an old pointer - case PlanIndex.fakeLookupUnitId - (planFakeMap plan) (planIndex plan) pkgid - of - Just (PreExisting ipkg) -> Just ipkg - Just (Configured _) -> Nothing - Just (Processing _) -> Nothing - Just (Installed _ (Just ipkg) _) -> Just ipkg - Just (Installed _ Nothing _) -> internalError depOnNonLib - Just (Failed _ _) -> internalError depOnFailed - Nothing -> internalError incomplete - incomplete = "install plan is not closed" - depOnFailed = "configured package depends on failed package" - depOnNonLib = "configured package depends on a non-library package" - --- | Marks packages in the graph as currently processing (e.g. building). --- --- * The package must exist in the graph and be in the configured state. --- -processing :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => [GenericReadyPackage srcpkg ipkg] - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -processing pkgs plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = PackageIndex.merge (planIndex plan) processingPkgs - } - processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs] - --- | Marks a package in the graph as completed. Also saves the build result for --- the completed package in the plan. --- --- * The package must exist in the graph and be in the processing state. --- * The package must have had no uninstalled dependent packages. --- -completed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId - -> Maybe ipkg -> iresult - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -completed pkgid mipkg buildResult plan = assert (invariant plan') plan' - where - plan' = plan { - -- NB: installation can change the IPID, so better - -- record it in the fake mapping... - planFakeMap = insert_fake_mapping mipkg - $ planFakeMap plan, - planIndex = PackageIndex.insert installed - . PackageIndex.deleteUnitId pkgid - $ planIndex plan - } - -- ...but be sure to use the *old* IPID for the lookup for the - -- preexisting record - installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult - insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg) - insert_fake_mapping _ = id - --- | Marks a package in the graph as having failed. It also marks all the --- packages that depended on it as having failed. --- --- * The package must exist in the graph and be in the processing --- state. --- -failed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId -- ^ The id of the package that failed to install - -> ifailure -- ^ The build result to use for the failed package - -> ifailure -- ^ The build result to use for its dependencies - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' - where - -- NB: failures don't update IPIDs - plan' = plan { - planIndex = PackageIndex.merge (planIndex plan) failures - } - ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid - failures = PackageIndex.fromList - $ Failed srcpkg buildResult - : [ Failed pkg' buildResult' - | Just pkg' <- map checkConfiguredPackage - $ packagesThatDependOn plan pkgid ] - --- | Lookup the reachable packages in the reverse dependency graph. --- -packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> UnitId - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -packagesThatDependOn plan pkgid = map (planPkgOf plan) - . tail - . Graph.reachable (planGraphRev plan) - . planVertexOf plan - $ Map.findWithDefault pkgid pkgid (planFakeMap plan) - --- | Lookup a package that we expect to be in the processing state. --- -lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> UnitId - -> GenericReadyPackage srcpkg ipkg -lookupProcessingPackage plan pkgid = - -- NB: processing packages are guaranteed to not indirect through - -- planFakeMap - case PackageIndex.lookupUnitId (planIndex plan) pkgid of - Just (Processing pkg) -> pkg - _ -> internalError $ "not in processing state or no such pkg " ++ - display pkgid - --- | Check a package that we expect to be in the configured or failed state. --- -checkConfiguredPackage :: (Package srcpkg, Package ipkg) - => GenericPlanPackage ipkg srcpkg iresult ifailure - -> Maybe srcpkg -checkConfiguredPackage (Configured pkg) = Just pkg -checkConfiguredPackage (Failed _ _) = Nothing -checkConfiguredPackage pkg = - internalError $ "not configured or no such pkg " ++ display (packageId pkg) - --- | Replace a ready package with a pre-existing one. The pre-existing one --- must have exactly the same dependencies as the source one was configured --- with. --- -preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId - -> ipkg - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -preexisting pkgid ipkg plan = assert (invariant plan') plan' - where - plan' = plan { - -- NB: installation can change the IPID, so better - -- record it in the fake mapping... - planFakeMap = Map.insert pkgid - (installedUnitId ipkg) - (planFakeMap plan), - planIndex = PackageIndex.insert (PreExisting ipkg) - -- ...but be sure to use the *old* IPID for the lookup for - -- the preexisting record - . PackageIndex.deleteUnitId pkgid - $ planIndex plan - } - --- | Replace a ready package with an installed one. The installed one --- must have exactly the same dependencies as the source one was configured --- with. --- -preinstalled :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId - -> Maybe ipkg -> iresult - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan' - where - plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) } - Just installed = do - Configured pkg <- PackageIndex.lookupUnitId (planIndex plan) pkgid - rpkg <- lookupReadyPackage plan pkg - return (Installed rpkg mipkg buildResult) - --- | Transform an install plan by mapping a function over all the packages in --- the plan. It can consistently change the 'UnitId' of all the packages, --- while preserving the same overall graph structure. --- --- The mapping function has a few constraints on it for correct operation. --- The mapping function /may/ change the 'UnitId' of the package, but it --- /must/ also remap the 'UnitId's of its dependencies using ths supplied --- remapping function. Apart from this consistent remapping it /may not/ --- change the structure of the dependencies. --- -mapPreservingGraph :: (HasUnitId ipkg, - HasUnitId srcpkg, - HasUnitId ipkg', PackageFixedDeps ipkg', - HasUnitId srcpkg', PackageFixedDeps srcpkg') - => ( (UnitId -> UnitId) - -> GenericPlanPackage ipkg srcpkg iresult ifailure - -> GenericPlanPackage ipkg' srcpkg' iresult' ifailure') - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg' srcpkg' iresult' ifailure' -mapPreservingGraph f plan = - mkInstallPlan (PackageIndex.fromList pkgs') - Map.empty -- empty fakeMap - (planIndepGoals plan) - where - -- The package mapping function may change the UnitId. So we - -- walk over the packages in dependency order keeping track of these - -- package id changes and use it to supply the correct set of package - -- dependencies as an extra input to the package mapping function. - -- - -- Having fully remapped all the deps this also means we can use an empty - -- FakeMap for the resulting install plan. - - (_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan) - - f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs) - where - pkg' = f (mapDep ipkgidMap) pkg - - ipkgidMap' - | ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap - | otherwise = ipkgidMap - where - ipkgid = installedUnitId pkg - ipkgid' = installedUnitId pkg' - - mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap - - --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => FakeMap -> Bool - -> PlanIndex ipkg srcpkg iresult ifailure - -> Bool -valid fakeMap indepGoals index = - null $ problems fakeMap indepGoals index - -data PlanProblem ipkg srcpkg iresult ifailure = - PackageMissingDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) - [PackageIdentifier] - | PackageCycle [GenericPlanPackage ipkg srcpkg iresult ifailure] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg iresult ifailure) - (GenericPlanPackage ipkg srcpkg iresult ifailure) - -showPlanProblem :: (Package ipkg, Package srcpkg) - => PlanProblem ipkg srcpkg iresult ifailure -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ display (packageId pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map display missingDeps) - -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (display.packageId) cycleGroup) - -showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ display name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ display (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ display (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" - where - showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" - showPlanState (Processing _) = "processing" - showPlanState (Installed _ _ _) = "installed" - showPlanState (Failed _ _) = "failed" - --- | For an invalid plan, produce a detailed list of problems as human readable --- error messages. This is mainly intended for debugging purposes. --- Use 'showPlanProblem' for a human readable explanation. --- -problems :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => FakeMap -> Bool - -> PlanIndex ipkg srcpkg iresult ifailure - -> [PlanProblem ipkg srcpkg iresult ifailure] -problems fakeMap indepGoals index = - - [ PackageMissingDeps pkg - (catMaybes - (map - (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index) - missingDeps)) - | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - PlanIndex.dependencyInconsistencies fakeMap indepGoals index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- PackageIndex.allPackages index - , Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index) - (CD.flatDeps (depends pkg)) - , not (stateDependencyRelation pkg pkg') ] - --- | The graph of packages (nodes) and dependencies (edges) must be acyclic. --- --- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --- which packages are involved in dependency cycles. --- -acyclic :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool -acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap - --- | An installation plan is closed if for every package in the set, all of --- its dependencies are also in the set. That is, the set is closed under the --- dependency relation. --- --- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --- which packages depend on packages not in the index. --- -closed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - PackageFixedDeps srcpkg) - => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool -closed fakeMap = null . PlanIndex.brokenPackages fakeMap - --- | An installation plan is consistent if all dependencies that target a --- single package name, target the same version. --- --- This is slightly subtle. It is not the same as requiring that there be at --- most one version of any package in the set. It only requires that of --- packages which have more than one other package depending on them. We could --- actually make the condition even more precise and say that different --- versions are OK so long as they are not both in the transitive closure of --- any other package (or equivalently that their inverse closures do not --- intersect). The point is we do not want to have any packages depending --- directly or indirectly on two different versions of the same package. The --- current definition is just a safe approximation of that. --- --- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --- find out which packages are. --- -consistent :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool -consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg iresult ifailure - -> GenericPlanPackage ipkg srcpkg iresult ifailure - -> Bool -stateDependencyRelation (PreExisting _) (PreExisting _) = True - -stateDependencyRelation (Configured _) (PreExisting _) = True -stateDependencyRelation (Configured _) (Configured _) = True -stateDependencyRelation (Configured _) (Processing _) = True -stateDependencyRelation (Configured _) (Installed _ _ _) = True - -stateDependencyRelation (Processing _) (PreExisting _) = True -stateDependencyRelation (Processing _) (Installed _ _ _) = True - -stateDependencyRelation (Installed _ _ _) (PreExisting _) = True -stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True - -stateDependencyRelation (Failed _ _) (PreExisting _) = True --- failed can depends on configured because a package can depend on --- several other packages and if one of the deps fail then we fail --- but we still depend on the other ones that did not fail: -stateDependencyRelation (Failed _ _) (Configured _) = True -stateDependencyRelation (Failed _ _) (Processing _) = True -stateDependencyRelation (Failed _ _) (Installed _ _ _) = True -stateDependencyRelation (Failed _ _) (Failed _ _) = True - -stateDependencyRelation _ _ = False - - --- | Compute the dependency closure of a package in a install plan --- -dependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -dependencyClosure plan = - map (planPkgOf plan) - . concatMap Tree.flatten - . Graph.dfs (planGraph plan) - . map (planVertexOf plan) - - -reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [UnitId] - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -reverseDependencyClosure plan = - map (planPkgOf plan) - . concatMap Tree.flatten - . Graph.dfs (planGraphRev plan) - . map (planVertexOf plan) - - -topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -topologicalOrder plan = - map (planPkgOf plan) - . Graph.topSort - $ planGraph plan - - -reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -reverseTopologicalOrder plan = - map (planPkgOf plan) - . Graph.topSort - $ planGraphRev plan +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + GenericInstallPlan, + PlanPackage, + GenericPlanPackage(..), + foldPlanPackage, + IsUnit, + + -- * Operations on 'InstallPlan's + new, + toGraph, + toList, + toMap, + keys, + keysSet, + planIndepGoals, + depends, + + fromSolverInstallPlan, + fromSolverInstallPlanWithProgress, + configureInstallPlan, + remove, + installed, + lookup, + directDeps, + revDirectDeps, + + -- * Traversal + executionOrder, + execute, + BuildOutcomes, + lookupBuildOutcome, + -- ** Traversal helpers + -- $traversal + Processing, + ready, + completed, + failed, + + -- * Display + showPlanGraph, + showInstallPlan, + + -- * Graph-like operations + reverseTopologicalOrder, + reverseDependencyClosure, + ) where + +import Distribution.Client.Types hiding (BuildOutcomes) +import qualified Distribution.PackageDescription as PD +import qualified Distribution.Simple.Configure as Configure +import qualified Distribution.Simple.Setup as Cabal + +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Package + ( Package(..), HasMungedPackageId(..) + , HasUnitId(..), UnitId ) +import Distribution.Solver.Types.SolverPackage +import Distribution.Client.JobControl +import Distribution.Text +import Text.PrettyPrint +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.InstSolverPackage + +import Distribution.Utils.LogProgress + +-- TODO: Need this when we compute final UnitIds +-- import qualified Distribution.Simple.Configure as Configure + +import Data.List + ( foldl', intercalate ) +import qualified Data.Foldable as Foldable (all) +import Data.Maybe + ( fromMaybe, catMaybes ) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, IsNode(..)) +import Distribution.Compat.Binary (Binary(..)) +import GHC.Generics +import Data.Typeable +import Control.Monad +import Control.Exception + ( assert ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) + +import Prelude hiding (lookup) + + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of source +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Source package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available as source packages which means they could +-- be re-installed if required, though there will also be packages which are +-- not available as source and cannot be re-installed. Very often there will be +-- extra versions available than are installed. Sometimes we may like to prefer +-- installed packages over source ones or perhaps always prefer the latest +-- available version whether installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and source +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaneously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +-- | Packages in an install plan +-- +-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage' +-- intentionally have no 'PackageInstalled' instance. `This is important: +-- PackageInstalled returns only library dependencies, but for package that +-- aren't yet installed we know many more kinds of dependencies (setup +-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on +-- dependencies in cabal-install should consider what to do with these +-- dependencies; if we give a 'PackageInstalled' instance it would be too easy +-- to get this wrong (and, for instance, call graph traversal functions from +-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. +data GenericPlanPackage ipkg srcpkg + = PreExisting ipkg + | Configured srcpkg + | Installed srcpkg + deriving (Eq, Show, Generic) + +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + +type IsUnit a = (IsNode a, Key a ~ UnitId) + +depends :: IsUnit a => a -> [UnitId] +depends = nodeNeighbors + +-- NB: Expanded constraint synonym here to avoid undecidable +-- instance errors in GHC 7.8 and earlier. +instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) + => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = UnitId + nodeKey (PreExisting ipkg) = nodeKey ipkg + nodeKey (Configured spkg) = nodeKey spkg + nodeKey (Installed spkg) = nodeKey spkg + nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg + nodeNeighbors (Configured spkg) = nodeNeighbors spkg + nodeNeighbors (Installed spkg) = nodeNeighbors spkg + +instance (Binary ipkg, Binary srcpkg) + => Binary (GenericPlanPackage ipkg srcpkg) + +type PlanPackage = GenericPlanPackage + InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) + +instance (Package ipkg, Package srcpkg) => + Package (GenericPlanPackage ipkg srcpkg) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + packageId (Installed spkg) = packageId spkg + +instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => + HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where + mungedId (PreExisting ipkg) = mungedId ipkg + mungedId (Configured spkg) = mungedId spkg + mungedId (Installed spkg) = mungedId spkg + +instance (HasUnitId ipkg, HasUnitId srcpkg) => + HasUnitId + (GenericPlanPackage ipkg srcpkg) where + installedUnitId (PreExisting ipkg) = installedUnitId ipkg + installedUnitId (Configured spkg) = installedUnitId spkg + installedUnitId (Installed spkg) = installedUnitId spkg + +instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => + HasConfiguredId (GenericPlanPackage ipkg srcpkg) where + configuredId (PreExisting ipkg) = configuredId ipkg + configuredId (Configured spkg) = configuredId spkg + configuredId (Installed spkg) = configuredId spkg + +data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { + planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)), + planIndepGoals :: !IndependentGoals + } + deriving (Typeable) + +-- | 'GenericInstallPlan' specialised to most commonly used types. +type InstallPlan = GenericInstallPlan + InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) + +-- | Smart constructor that deals with caching the 'Graph' representation. +-- +mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) + => String + -> Graph (GenericPlanPackage ipkg srcpkg) + -> IndependentGoals + -> GenericInstallPlan ipkg srcpkg +mkInstallPlan loc graph indepGoals = + assert (valid loc graph) + GenericInstallPlan { + planGraph = graph, + planIndepGoals = indepGoals + } + +internalError :: String -> String -> a +internalError loc msg = error $ "internal error in InstallPlan." ++ loc + ++ if null msg then "" else ": " ++ msg + +instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, + Binary ipkg, Binary srcpkg) + => Binary (GenericInstallPlan ipkg srcpkg) where + put GenericInstallPlan { + planGraph = graph, + planIndepGoals = indepGoals + } = put (graph, indepGoals) + + get = do + (graph, indepGoals) <- get + return $! mkInstallPlan "(instance Binary)" graph indepGoals + +showPlanGraph :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) -> String +showPlanGraph graph = renderStyle defaultStyle $ + vcat (map dispPlanPackage (Graph.toList graph)) + where dispPlanPackage p = + hang (hsep [ text (showPlanPackageTag p) + , disp (packageId p) + , parens (disp (nodeKey p))]) 2 + (vcat (map disp (nodeNeighbors p))) + +showInstallPlan :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg -> String +showInstallPlan = showPlanGraph . planGraph + +showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String +showPlanPackageTag (PreExisting _) = "PreExisting" +showPlanPackageTag (Configured _) = "Configured" +showPlanPackageTag (Installed _) = "Installed" + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: (IsUnit ipkg, IsUnit srcpkg) + => IndependentGoals + -> Graph (GenericPlanPackage ipkg srcpkg) + -> GenericInstallPlan ipkg srcpkg +new indepGoals graph = mkInstallPlan "new" graph indepGoals + +toGraph :: GenericInstallPlan ipkg srcpkg + -> Graph (GenericPlanPackage ipkg srcpkg) +toGraph = planGraph + +toList :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +toList = Graph.toList . planGraph + +toMap :: GenericInstallPlan ipkg srcpkg + -> Map UnitId (GenericPlanPackage ipkg srcpkg) +toMap = Graph.toMap . planGraph + +keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys = Graph.keys . planGraph + +keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet = Graph.keysSet . planGraph + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +remove shouldRemove plan = + mkInstallPlan "remove" newGraph (planIndepGoals plan) + where + newGraph = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + +-- | Change a number of packages in the 'Configured' state to the 'Installed' +-- state. +-- +-- To preserve invariants, the package must have all of its dependencies +-- already installed too (that is 'PreExisting' or 'Installed'). +-- +installed :: (IsUnit ipkg, IsUnit srcpkg) + => (srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg +installed shouldBeInstalled installPlan = + foldl' markInstalled installPlan + [ pkg + | Configured pkg <- reverseTopologicalOrder installPlan + , shouldBeInstalled pkg ] + where + markInstalled plan pkg = + assert (all isInstalled (directDeps plan (nodeKey pkg))) $ + plan { + planGraph = Graph.insert (Installed pkg) (planGraph plan) + } + +-- | Lookup a package in the plan. +-- +lookup :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> UnitId + -> Maybe (GenericPlanPackage ipkg srcpkg) +lookup plan pkgid = Graph.lookup pkgid (planGraph plan) + +-- | Find all the direct dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +directDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +directDeps plan pkgid = + case Graph.neighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "directDeps" "package not in graph" + +-- | Find all the direct reverse dependencies of the given package. +-- +-- Note that the package must exist in the plan or it is an error. +-- +revDirectDeps :: GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] +revDirectDeps plan pkgid = + case Graph.revNeighbors (planGraph plan) pkgid of + Just deps -> deps + Nothing -> internalError "revDirectDeps" "package not in graph" + +-- | Return all the packages in the 'InstallPlan' in reverse topological order. +-- That is, for each package, all dependencies of the package appear first. +-- +-- Compared to 'executionOrder', this function returns all the installed and +-- source packages rather than just the source ones. Also, while both this +-- and 'executionOrder' produce reverse topological orderings of the package +-- dependency graph, it is not necessarily exactly the same order. +-- +reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] +reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) + + +-- | Return the packages in the plan that depend directly or indirectly on the +-- given packages. +-- +reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +reverseDependencyClosure plan = fromMaybe [] + . Graph.revClosure (planGraph plan) + + +-- Alert alert! Why does SolverId map to a LIST of plan packages? +-- The sordid story has to do with 'build-depends' on a package +-- with libraries and executables. In an ideal world, we would +-- ONLY depend on the library in this situation. But c.f. #3661 +-- some people rely on the build-depends to ALSO implicitly +-- depend on an executable. +-- +-- I don't want to commit to a strategy yet, so the only possible +-- thing you can do in this case is return EVERYTHING and let +-- the client filter out what they want (executables? libraries? +-- etc). This similarly implies we can't return a 'ConfiguredId' +-- because that's not enough information. + +fromSolverInstallPlan :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> GenericInstallPlan ipkg srcpkg +fromSolverInstallPlan f plan = + mkInstallPlan "fromSolverInstallPlan" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + where + (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + + f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) + where + pkgs' = f (mapDep pidMap ipiMap) pkg + + (pidMap', ipiMap') + = case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + + mapDep _ ipiMap (PreExistingId _pid uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). + + +fromSolverInstallPlanWithProgress :: + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) + -> SolverInstallPlan.SolverPlanPackage + -> LogProgress [GenericPlanPackage ipkg srcpkg] ) + -> SolverInstallPlan + -> LogProgress (GenericInstallPlan ipkg srcpkg) +fromSolverInstallPlanWithProgress f plan = do + (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) + return $ mkInstallPlan "fromSolverInstallPlanWithProgress" + (Graph.fromDistinctList pkgs'') + (SolverInstallPlan.planIndepGoals plan) + where + f' (pidMap, ipiMap, pkgs) pkg = do + pkgs' <- f (mapDep pidMap ipiMap) pkg + let (pidMap', ipiMap') + = case nodeKey pkg of + PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + return (pidMap', ipiMap', pkgs' ++ pkgs) + + mapDep _ ipiMap (PreExistingId _pid uid) + | Just pkgs <- Map.lookup uid ipiMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). + +-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. +-- Similar to 'elaboratedInstallPlan' +configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan +configureInstallPlan configFlags solverPlan = + flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> + [case planpkg of + SolverInstallPlan.PreExisting pkg -> + PreExisting (instSolverPkgIPI pkg) + + SolverInstallPlan.Configured pkg -> + Configured (configureSolverPackage mapDep pkg) + ] + where + configureSolverPackage :: (SolverId -> [PlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ConfiguredPackage UnresolvedPkgLoc + configureSolverPackage mapDep spkg = + ConfiguredPackage { + confPkgId = Configure.computeComponentId + (Cabal.fromFlagOrDefault False + (Cabal.configDeterministic configFlags)) + Cabal.NoFlag + Cabal.NoFlag + (packageId spkg) + PD.CLibName + (Just (map confInstId (CD.libraryDeps deps), + solverPkgFlags spkg)), + confPkgSource = solverPkgSource spkg, + confPkgFlags = solverPkgFlags spkg, + confPkgStanzas = solverPkgStanzas spkg, + confPkgDeps = deps + -- NB: no support for executable dependencies + } + where + deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) + + +-- ------------------------------------------------------------ +-- * Primitives for traversing plans +-- ------------------------------------------------------------ + +-- $traversal +-- +-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, +-- may make use of the 'Processing' type and the associated operations +-- 'ready', 'completed' and 'failed'. +-- +-- The 'Processing' type is used to keep track of the state of a traversal and +-- includes the set of packages that are in the processing state, e.g. in the +-- process of being installed, plus those that have been completed and those +-- where processing failed. +-- +-- Traversal algorithms start with an 'InstallPlan': +-- +-- * Initially there will be certain packages that can be processed immediately +-- (since they are configured source packages and have all their dependencies +-- installed already). The function 'ready' returns these packages plus a +-- 'Processing' state that marks these same packages as being in the +-- processing state. +-- +-- * The algorithm must now arrange for these packages to be processed +-- (possibly in parallel). When a package has completed processing, the +-- algorithm needs to know which other packages (if any) are now ready to +-- process as a result. The 'completed' function marks a package as completed +-- and returns any packages that are newly in the processing state (ie ready +-- to process), along with the updated 'Processing' state. +-- +-- * If failure is possible then when processing a package fails, the algorithm +-- needs to know which other packages have also failed as a result. The +-- 'failed' function marks the given package as failed as well as all the +-- other packages that depend on the failed package. In addition it returns +-- the other failed packages. + + +-- | The 'Processing' type is used to keep track of the state of a traversal +-- and includes the set of packages that are in the processing state, e.g. in +-- the process of being installed, plus those that have been completed and +-- those where processing failed. +-- +data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) + -- processing, completed, failed + +-- | The packages in the plan that are initially ready to be installed. +-- That is they are in the configured state and have all their dependencies +-- installed already. +-- +-- The result is both the packages that are now ready to be installed and also +-- a 'Processing' state containing those same packages. The assumption is that +-- all the packages that are ready will now be processed and so we can consider +-- them to be in the processing state. +-- +ready :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> ([GenericReadyPackage srcpkg], Processing) +ready plan = + assert (processingInvariant plan processing) $ + (readyPackages, processing) + where + !processing = + Processing + (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) + (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ]) + Set.empty + readyPackages = + [ ReadyPackage pkg + | Configured pkg <- toList plan + , all isInstalled (directDeps plan (nodeKey pkg)) + ] + +isInstalled :: GenericPlanPackage a b -> Bool +isInstalled (PreExisting {}) = True +isInstalled (Installed {}) = True +isInstalled _ = False + +-- | Given a package in the processing state, mark the package as completed +-- and return any packages that are newly in the processing state (ie ready to +-- process), along with the updated 'Processing' state. +-- +completed :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([GenericReadyPackage srcpkg], Processing) +completed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (processingInvariant plan processing') $ + + ( map asReadyPackage newlyReady + , processing' ) + where + completedSet' = Set.insert pkgid completedSet + + -- each direct reverse dep where all direct deps are completed + newlyReady = [ dep + | dep <- revDirectDeps plan pkgid + , all ((`Set.member` completedSet') . nodeKey) + (directDeps plan (nodeKey dep)) + ] + + processingSet' = foldl' (flip Set.insert) + (Set.delete pkgid processingSet) + (map nodeKey newlyReady) + processing' = Processing processingSet' completedSet' failedSet + + asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage _ = internalError "completed" "" + +failed :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([srcpkg], Processing) +failed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ + assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ + -- but note that some newlyFailed may already be in the failed set + -- since one package can depend on two packages that both fail and + -- so would be in the rev-dep closure for both. + assert (processingInvariant plan processing') $ + + ( map asConfiguredPackage (tail newlyFailed) + , processing' ) + where + processingSet' = Set.delete pkgid processingSet + failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds + newlyFailedIds = map nodeKey newlyFailed + newlyFailed = fromMaybe (internalError "failed" "package not in graph") + $ Graph.revClosure (planGraph plan) [pkgid] + processing' = Processing processingSet' completedSet failedSet' + + asConfiguredPackage (Configured pkg) = pkg + asConfiguredPackage _ = internalError "failed" "not in configured state" + +processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> Bool +processingInvariant plan (Processing processingSet completedSet failedSet) = + + -- All the packages in the three sets are actually in the graph + assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $ + assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $ + + -- The processing, completed and failed sets are disjoint from each other + assert (noIntersection processingSet completedSet) $ + assert (noIntersection processingSet failedSet) $ + assert (noIntersection failedSet completedSet) $ + + -- Packages that depend on a package that's still processing cannot be + -- completed + assert (noIntersection (reverseClosure processingSet) completedSet) $ + + -- On the other hand, packages that depend on a package that's still + -- processing /can/ have failed (since they may have depended on multiple + -- packages that were processing, but it only takes one to fail to cause + -- knock-on failures) so it is quite possible to have an + -- intersection (reverseClosure processingSet) failedSet + + -- The failed set is upwards closed, i.e. equal to its own rev dep closure + assert (failedSet == reverseClosure failedSet) $ + + -- All immediate reverse deps of packges that are currently processing + -- are not currently being processed (ie not in the processing set). + assert (and [ rdeppkgid `Set.notMember` processingSet + | pkgid <- Set.toList processingSet + , rdeppkgid <- maybe (internalError "processingInvariant" "") + (map nodeKey) + (Graph.revNeighbors (planGraph plan) pkgid) + ]) $ + + -- Packages from the processing or failed sets are only ever in the + -- configured state. + assert (and [ case Graph.lookup pkgid (planGraph plan) of + Just (Configured _) -> True + Just (PreExisting _) -> False + Just (Installed _) -> False + Nothing -> False + | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]) + + -- We use asserts rather than returning False so that on failure we get + -- better details on which bit of the invariant was violated. + True + where + reverseClosure = Set.fromList + . map nodeKey + . fromMaybe (internalError "processingInvariant" "") + . Graph.revClosure (planGraph plan) + . Set.toList + noIntersection a b = Set.null (Set.intersection a b) + + +-- ------------------------------------------------------------ +-- * Traversing plans +-- ------------------------------------------------------------ + +-- | Flatten an 'InstallPlan', producing the sequence of source packages in +-- the order in which they would be processed when the plan is executed. This +-- can be used for simultations or presenting execution dry-runs. +-- +-- It is guaranteed to give the same order as using 'execute' (with a serial +-- in-order 'JobControl'), which is a reverse topological orderings of the +-- source packages in the dependency graph, albeit not necessarily exactly the +-- same ordering as that produced by 'reverseTopologicalOrder'. +-- +executionOrder :: (IsUnit ipkg, IsUnit srcpkg) + => GenericInstallPlan ipkg srcpkg + -> [GenericReadyPackage srcpkg] +executionOrder plan = + let (newpkgs, processing) = ready plan + in tryNewTasks processing newpkgs + where + tryNewTasks _processing [] = [] + tryNewTasks processing (p:todo) = waitForTasks processing p todo + + waitForTasks processing p todo = + p : tryNewTasks processing' (todo++nextpkgs) + where + (nextpkgs, processing') = completed plan processing (nodeKey p) + + +-- ------------------------------------------------------------ +-- * Executing plans +-- ------------------------------------------------------------ + +-- | The set of results we get from executing an install plan. +-- +type BuildOutcomes failure result = Map UnitId (Either failure result) + +-- | Lookup the build result for a single package. +-- +lookupBuildOutcome :: HasUnitId pkg + => pkg -> BuildOutcomes failure result + -> Maybe (Either failure result) +lookupBuildOutcome = Map.lookup . installedUnitId + +-- | Execute an install plan. This traverses the plan in dependency order. +-- +-- Executing each individual package can fail and if so all dependents fail +-- too. The result for each package is collected as a 'BuildOutcomes' map. +-- +-- Visiting each package happens with optional parallelism, as determined by +-- the 'JobControl'. By default, after any failure we stop as soon as possible +-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour +-- can be reversed to keep going and build as many packages as possible. +-- +-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages +-- in the plan. In particular in the default mode where we stop as soon as +-- possible after a failure then there may be packages which are skipped and +-- these will have no 'BuildOutcome'. +-- +execute :: forall m ipkg srcpkg result failure. + (IsUnit ipkg, IsUnit srcpkg, + Monad m) + => JobControl m (UnitId, Either failure result) + -> Bool -- ^ Keep going after failure + -> (srcpkg -> failure) -- ^ Value for dependents of failed packages + -> GenericInstallPlan ipkg srcpkg + -> (GenericReadyPackage srcpkg -> m (Either failure result)) + -> m (BuildOutcomes failure result) +execute jobCtl keepGoing depFailure plan installPkg = + let (newpkgs, processing) = ready plan + in tryNewTasks Map.empty False False processing newpkgs + where + tryNewTasks :: BuildOutcomes failure result + -> Bool -> Bool -> Processing + -> [GenericReadyPackage srcpkg] + -> m (BuildOutcomes failure result) + + tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs + -- we were in the process of cancelling and now we're finished + | tasksFailed && not keepGoing && not tasksRemaining + = return results + + -- we are still in the process of cancelling, wait for remaining tasks + | tasksFailed && not keepGoing && tasksRemaining + = waitForTasks results tasksFailed processing + + -- no new tasks to do and all tasks are done so we're finished + | null newpkgs && not tasksRemaining + = return results + + -- no new tasks to do, remaining tasks to wait for + | null newpkgs + = waitForTasks results tasksFailed processing + + -- new tasks to do, spawn them, then wait for tasks to complete + | otherwise + = do sequence_ [ spawnJob jobCtl $ do + result <- installPkg pkg + return (nodeKey pkg, result) + | pkg <- newpkgs ] + waitForTasks results tasksFailed processing + + waitForTasks :: BuildOutcomes failure result + -> Bool -> Processing + -> m (BuildOutcomes failure result) + waitForTasks !results tasksFailed !processing = do + (pkgid, result) <- collectJob jobCtl + + case result of + + Right _success -> do + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' tasksFailed tasksRemaining + processing' nextpkgs + where + results' = Map.insert pkgid result results + (nextpkgs, processing') = completed plan processing pkgid + + Left _failure -> do + -- if this is the first failure and we're not trying to keep going + -- then try to cancel as many of the remaining jobs as possible + when (not tasksFailed && not keepGoing) $ + cancelJobs jobCtl + + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' True tasksRemaining processing' [] + where + (depsfailed, processing') = failed plan processing pkgid + results' = Map.insert pkgid result results `Map.union` depResults + depResults = Map.fromList + [ (nodeKey deppkg, Left (depFailure deppkg)) + | deppkg <- depsfailed ] + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is closed, acyclic +-- and respects the package state relation. +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: (IsUnit ipkg, IsUnit srcpkg) + => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool +valid loc graph = + case problems graph of + [] -> True + ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) + +data PlanProblem ipkg srcpkg = + PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] + | PackageCycle [GenericPlanPackage ipkg srcpkg] + | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + (GenericPlanPackage ipkg srcpkg) + +showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg) + => PlanProblem ipkg srcpkg -> String +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (nodeKey pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display . nodeKey) cycleGroup) +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (nodeKey pkg) + ++ " is in the " ++ showPlanPackageTag pkg + ++ " state but it depends on package " ++ display (nodeKey pkg') + ++ " which is in the " ++ showPlanPackageTag pkg' + ++ " state" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: (IsUnit ipkg, IsUnit srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +problems graph = + + [ PackageMissingDeps pkg + (catMaybes + (map + (fmap nodeKey . flip Graph.lookup graph) + missingDeps)) + | (pkg, missingDeps) <- Graph.broken graph ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles graph ] +{- + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals graph ] + --TODO: consider re-enabling this one, see SolverInstallPlan +-} + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Graph.toList graph + , Just pkg' <- map (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @stateDependencyRelation a b = True@. +-- +stateDependencyRelation :: GenericPlanPackage ipkg srcpkg + -> GenericPlanPackage ipkg srcpkg -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation Installed{} PreExisting{} = True +stateDependencyRelation Installed{} Installed{} = True + +stateDependencyRelation Configured{} PreExisting{} = True +stateDependencyRelation Configured{} Installed{} = True +stateDependencyRelation Configured{} Configured{} = True + +stateDependencyRelation _ _ = False diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -16,10 +16,12 @@ symlinkBinary, ) where -#if mingw32_HOST_OS +#ifdef mingw32_HOST_OS import Distribution.Package (PackageIdentifier) +import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler @@ -28,33 +30,36 @@ symlinkBinaries :: Platform -> Compiler -> ConfigFlags -> InstallFlags - -> InstallPlan - -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries _ _ _ _ _ = return [] + -> InstallPlan + -> BuildOutcomes + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] +symlinkBinaries _ _ _ _ _ _ = return [] -symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary :: FilePath -> FilePath -> UnqualComponentName -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" #else import Distribution.Client.Types - ( SourcePackage(..) - , GenericReadyPackage(..), ReadyPackage, enableStanzas - , ConfiguredPackage(..) , fakeUnitId) + ( ConfiguredPackage(..), BuildOutcomes ) import Distribution.Client.Setup ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.OptionalStanza + import Distribution.Package - ( PackageIdentifier, Package(packageId), UnitId(..) ) + ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) +import Distribution.Types.UnqualComponentName import Distribution.Compiler ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) + ( finalizePD ) import Distribution.Simple.Setup ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs @@ -62,6 +67,8 @@ ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System ( Platform ) +import Distribution.Text + ( display ) import System.Posix.Files ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink @@ -104,8 +111,9 @@ -> ConfigFlags -> InstallFlags -> InstallPlan - -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries platform comp configFlags installFlags plan = + -> BuildOutcomes + -> IO [(PackageIdentifier, UnqualComponentName, FilePath)] +symlinkBinaries platform comp configFlags installFlags plan buildOutcomes = case flagToMaybe (installSymlinkBinDir installFlags) of Nothing -> return [] Just symlinkBinDir @@ -123,31 +131,32 @@ then return Nothing else return (Just (pkgid, publicExeName, privateBinDir privateExeName)) - | (ReadyPackage (ConfiguredPackage _ _flags _ _) _, pkg, exe) <- exes + | (rpkg, pkg, exe) <- exes , let pkgid = packageId pkg -- This is a bit dodgy; probably won't work for Backpack packages - ipid = fakeUnitId pkgid + ipid = installedUnitId rpkg publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ publicExeName ++ suffix + privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix prefix = substTemplate pkgid ipid prefixTemplate suffix = substTemplate pkgid ipid suffixTemplate ] where exes = [ (cpkg, pkg, exe) - | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan - , let pkg = pkgDescription cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList plan + , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of + Just (Right _success) -> True + _ -> False + , let pkg :: PackageDescription + pkg = pkgDescription cpkg , exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) ] - pkgDescription :: ReadyPackage -> PackageDescription - pkgDescription (ReadyPackage (ConfiguredPackage - (SourcePackage _ pkg _ _) - flags stanzas _) - _) = - case finalizePackageDescription flags + pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _) + flags stanzas _) = + case finalizePD flags (enableStanzas stanzas) (const True) - platform cinfo [] (enableStanzas stanzas pkg) of - Left _ -> error "finalizePackageDescription ReadyPackage failed" + platform cinfo [] pkg of + Left _ -> error "finalizePD ReadyPackage failed" Right (desc, _) -> desc -- This is sadly rather complicated. We're kind of re-doing part of the @@ -177,30 +186,32 @@ cinfo = compilerInfo comp (CompilerId compilerFlavor _) = compilerInfoId cinfo -symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir - -- eg @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir - -- eg @/home/user/.cabal/bin@ - -> String -- ^ The name of the executable to go in the public - -- bin dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was successful. @False@ - -- if there was another file there already that we - -- did not own. Other errors like permission errors - -- just propagate as exceptions. +symlinkBinary :: + FilePath -- ^ The canonical path of the public bin dir eg + -- @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir eg + -- @/home/user/.cabal/bin@ + -> UnqualComponentName -- ^ The name of the executable to go in the public bin + -- dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was successful. @False@ if + -- there was another file there already that we did + -- not own. Other errors like permission errors just + -- propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) + ok <- targetOkToOverwrite (publicBindir publicName') (privateBindir privateName) case ok of NotOurFile -> return False NotExists -> mkLink >> return True OkToOverwrite -> rmLink >> mkLink >> return True where + publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir privateName) - (publicBindir publicName) - rmLink = removeLink (publicBindir publicName) + (publicBindir publicName') + rmLink = removeLink (publicBindir publicName') -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or diff --git a/Distribution/Client/JobControl.hs b/Distribution/Client/JobControl.hs --- a/Distribution/Client/JobControl.hs +++ b/Distribution/Client/JobControl.hs @@ -16,6 +16,8 @@ newParallelJobControl, spawnJob, collectJob, + remainingJobs, + cancelJobs, JobLimit, newJobLimit, @@ -27,48 +29,131 @@ ) where import Control.Monad -import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem) -import Control.Exception (SomeException, bracket_, mask, throw, try) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TChan +import Control.Exception (SomeException, bracket_, throwIO, try) import Distribution.Client.Compat.Semaphore + +-- | A simple concurrency abstraction. Jobs can be spawned and can complete +-- in any order. This allows both serial and parallel implementations. +-- data JobControl m a = JobControl { + -- | Add a new job to the pool of jobs spawnJob :: m a -> m (), - collectJob :: m a + + -- | Wait until one job is complete + collectJob :: m a, + + -- | Returns True if there are any outstanding jobs + -- (ie spawned but yet to be collected) + remainingJobs :: m Bool, + + -- | Try to cancel any outstanding but not-yet-started jobs. + -- Call 'remainingJobs' after this to find out if any jobs are left + -- (ie could not be cancelled). + cancelJobs :: m () } +-- | Make a 'JobControl' that executes all jobs serially and in order. +-- It only executes jobs on demand when they are collected, not eagerly. +-- +-- Cancelling will cancel /all/ jobs that have not been collected yet. +-- newSerialJobControl :: IO (JobControl IO a) newSerialJobControl = do - queue <- newChan + qVar <- newTChanIO return JobControl { - spawnJob = spawn queue, - collectJob = collect queue + spawnJob = spawn qVar, + collectJob = collect qVar, + remainingJobs = remaining qVar, + cancelJobs = cancel qVar } where - spawn :: Chan (IO a) -> IO a -> IO () - spawn = writeChan + spawn :: TChan (IO a) -> IO a -> IO () + spawn qVar job = atomically $ writeTChan qVar job - collect :: Chan (IO a) -> IO a - collect = join . readChan + collect :: TChan (IO a) -> IO a + collect qVar = + join $ atomically $ readTChan qVar -newParallelJobControl :: IO (JobControl IO a) -newParallelJobControl = do - resultVar <- newEmptyMVar + remaining :: TChan (IO a) -> IO Bool + remaining qVar = fmap not $ atomically $ isEmptyTChan qVar + + cancel :: TChan (IO a) -> IO () + cancel qVar = do + _ <- atomically $ readAllTChan qVar + return () + +-- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given +-- maximum degree of parallelism. +-- +-- Cancelling will cancel jobs that have not yet begun executing, but jobs +-- that have already been executed or are currently executing cannot be +-- cancelled. +-- +newParallelJobControl :: Int -> IO (JobControl IO a) +newParallelJobControl n | n < 1 || n > 1000 = + error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n +newParallelJobControl maxJobLimit = do + inqVar <- newTChanIO + outqVar <- newTChanIO + countVar <- newTVarIO 0 + replicateM_ maxJobLimit $ + forkIO $ + worker inqVar outqVar return JobControl { - spawnJob = spawn resultVar, - collectJob = collect resultVar + spawnJob = spawn inqVar countVar, + collectJob = collect outqVar countVar, + remainingJobs = remaining countVar, + cancelJobs = cancel inqVar countVar } where - spawn :: MVar (Either SomeException a) -> IO a -> IO () - spawn resultVar job = - mask $ \restore -> - forkIO (do res <- try (restore job) - putMVar resultVar res) - >> return () + worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO () + worker inqVar outqVar = + forever $ do + job <- atomically $ readTChan inqVar + res <- try job + atomically $ writeTChan outqVar res - collect :: MVar (Either SomeException a) -> IO a - collect resultVar = - takeMVar resultVar >>= either throw return + spawn :: TChan (IO a) -> TVar Int -> IO a -> IO () + spawn inqVar countVar job = + atomically $ do + modifyTVar' countVar (+1) + writeTChan inqVar job + + collect :: TChan (Either SomeException a) -> TVar Int -> IO a + collect outqVar countVar = do + res <- atomically $ do + modifyTVar' countVar (subtract 1) + readTChan outqVar + either throwIO return res + + remaining :: TVar Int -> IO Bool + remaining countVar = fmap (/=0) $ atomically $ readTVar countVar + + cancel :: TChan (IO a) -> TVar Int -> IO () + cancel inqVar countVar = + atomically $ do + xs <- readAllTChan inqVar + modifyTVar' countVar (subtract (length xs)) + +readAllTChan :: TChan a -> STM [a] +readAllTChan qvar = go [] + where + go xs = do + mx <- tryReadTChan qvar + case mx of + Nothing -> return (reverse xs) + Just x -> go (x:xs) + +------------------------- +-- Job limits and locks +-- data JobLimit = JobLimit QSem diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -14,38 +14,41 @@ ) where import Distribution.Package - ( PackageName(..), Package(..), packageName, packageVersion - , Dependency(..), simplifyDependency - , UnitId ) + ( PackageName, Package(..), packageName + , packageVersion, UnitId ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.PackageDescription as Source import Distribution.PackageDescription - ( Flag(..), FlagName(..) ) + ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils - ( equating, comparing, die, notice ) + ( equating, comparing, die', notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version - ( Version(..), VersionRange, withinRange, anyVersion + ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) import Distribution.Text ( Text(disp), display ) +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + import Distribution.Client.Types - ( SourcePackage(..), SourcePackageDb(..) ) -import Distribution.Client.Dependency.Types - ( PackageConstraint(..) ) + ( SourcePackageDb(..) + , UnresolvedSourcePackage ) import Distribution.Client.Targets ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup @@ -61,7 +64,7 @@ import Data.List ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) import Data.Maybe - ( listToMaybe, fromJust, fromMaybe, isJust ) + ( listToMaybe, fromJust, fromMaybe, isJust, maybeToList ) import qualified Data.Map as Map import Data.Tree as Tree import Control.Monad @@ -78,19 +81,19 @@ -> PackageDBStack -> RepoContext -> Compiler - -> ProgramConfiguration + -> ProgramDb -> ListFlags -> [String] -> IO [PackageDisplayInfo] -getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf +getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt let sourcePkgIndex = packageIndex sourcePkgDb prefs name = fromMaybe anyVersion (Map.lookup name (packagePreferences sourcePkgDb)) pkgsInfo :: - [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] pkgsInfo -- gather info for all packages | null pats = mergePackages @@ -101,7 +104,7 @@ | otherwise = pkgsInfoMatching pkgsInfoMatching :: - [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] + [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])] pkgsInfoMatching = let matchingInstalled = matchingPackages InstalledPackageIndex.searchByNameSubstring @@ -134,12 +137,12 @@ -> PackageDBStack -> RepoContext -> Compiler - -> ProgramConfiguration + -> ProgramDb -> ListFlags -> [String] -> IO () -list verbosity packageDBs repos comp conf listFlags pats = do - matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats +list verbosity packageDBs repos comp progdb listFlags pats = do + matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats if simpleOutput then putStr $ unlines @@ -164,7 +167,7 @@ -> PackageDBStack -> RepoContext -> Compiler - -> ProgramConfiguration + -> ProgramDb -> GlobalFlags -> InfoFlags -> [UserTarget] @@ -172,10 +175,10 @@ info verbosity _ _ _ _ _ _ [] = notice verbosity "No packages requested. Nothing to do." -info verbosity packageDBs repoCtxt comp conf +info verbosity packageDBs repoCtxt comp progdb globalFlags _listFlags userTargets = do - installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt let sourcePkgIndex = packageIndex sourcePkgDb prefs name = fromMaybe anyVersion @@ -194,7 +197,7 @@ sourcePkgs' userTargets pkgsinfo <- sequence - [ do pkginfo <- either die return $ + [ do pkginfo <- either (die' verbosity) return $ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex pkgSpecifier @@ -206,11 +209,11 @@ where gatherPkgInfo :: (PackageName -> VersionRange) -> InstalledPackageIndex -> - PackageIndex.PackageIndex SourcePackage -> - PackageSpecifier SourcePackage -> + PackageIndex.PackageIndex UnresolvedSourcePackage -> + PackageSpecifier UnresolvedSourcePackage -> Either String PackageDisplayInfo gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name constraints) + (NamedPackage name props) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " @@ -235,7 +238,7 @@ -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] + verConstraints = [ vr | PackagePropertyVersion vr <- props ] gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = @@ -251,8 +254,8 @@ (PackageName -> VersionRange) -> PackageName -> InstalledPackageIndex - -> PackageIndex.PackageIndex SourcePackage - -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage]) + -> PackageIndex.PackageIndex UnresolvedSourcePackage + -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = (pref, installedPkgs, sourcePkgs) where @@ -268,7 +271,7 @@ data PackageDisplayInfo = PackageDisplayInfo { pkgName :: PackageName, selectedVersion :: Maybe Version, - selectedSourcePkg :: Maybe SourcePackage, + selectedSourcePkg :: Maybe UnresolvedSourcePackage, installedVersions :: [Version], sourceVersions :: [Version], preferredVersions :: VersionRange, @@ -285,7 +288,7 @@ flags :: [Flag], hasLib :: Bool, hasExe :: Bool, - executables :: [String], + executables :: [UnqualComponentName], modules :: [ModuleName], haddockHtml :: FilePath, haveTarball :: Bool @@ -346,7 +349,7 @@ , entry "Author" author hideIfNull reflowLines , entry "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) + , entry "Executables" executables hideIfNull (commaSep disp) , entry "Flags" flags hideIfNull (commaSep dispFlag) , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) , entry "Documentation" haddockHtml showIfInstalled text @@ -378,7 +381,7 @@ orNotSpecified = altText null "[ Not specified ]" commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f - dispFlag f = case flagName f of FlagName n -> text n + dispFlag = text . unFlagName . flagName dispYesNo True = text "Yes" dispYesNo False = text "No" @@ -417,8 +420,8 @@ -- mergePackageInfo :: VersionRange -> [Installed.InstalledPackageInfo] - -> [SourcePackage] - -> Maybe SourcePackage + -> [UnresolvedSourcePackage] + -> Maybe UnresolvedSourcePackage -> Bool -> PackageDisplayInfo mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = @@ -462,7 +465,8 @@ executables = map fst (maybe [] Source.condExecutables sourceGeneric), modules = combine (map Installed.exposedName . Installed.exposedModules) installed - (maybe [] getListOfExposedModules . Source.library) + -- NB: only for the PUBLIC library + (concatMap getListOfExposedModules . maybeToList . Source.library) source, dependencies = combine (map (SourceDependency . simplifyDependency) @@ -520,10 +524,10 @@ -- both be empty. -- mergePackages :: [Installed.InstalledPackageInfo] - -> [SourcePackage] + -> [UnresolvedSourcePackage] -> [( PackageName , [Installed.InstalledPackageInfo] - , [SourcePackage] )] + , [UnresolvedSourcePackage] )] mergePackages installedPkgs sourcePkgs = map collect $ mergeBy (\i a -> fst i `compare` fst a) @@ -567,13 +571,13 @@ -- interestingVersions :: (Version -> Bool) -> [Version] -> [Version] interestingVersions pref = - map ((\ns -> Version ns []) . fst) . filter snd + map (mkVersion . fst) . filter snd . concat . Tree.levels . swizzleTree - . reorderTree (\(Node (v,_) _) -> pref (Version v [])) + . reorderTree (\(Node (v,_) _) -> pref (mkVersion v)) . reverseTree . mkTree - . map versionBranch + . map versionNumbers where swizzleTree = unfoldTree (spine []) diff --git a/Distribution/Client/Manpage.hs b/Distribution/Client/Manpage.hs --- a/Distribution/Client/Manpage.hs +++ b/Distribution/Client/Manpage.hs @@ -56,7 +56,7 @@ , "installing existing packages and developing new packages. " , "It can be used to work with local packages or to install packages from online package archives, " , "including automatically installing dependencies. By default it is configured to use Hackage, " - , "which is Haskell’s central package archive that contains thousands of libraries and applications " + , "which is Haskell's central package archive that contains thousands of libraries and applications " , "in the Cabal package format." , ".SH OPTIONS" , "Global options:" diff --git a/Distribution/Client/Nix.hs b/Distribution/Client/Nix.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Nix.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Distribution.Client.Nix + ( findNixExpr + , inNixShell + , nixInstantiate + , nixShell + , nixShellIfSandboxed + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Exception (bracket, catch) +import Control.Monad (filterM, when, unless) +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist + , doesFileExist, removeDirectoryRecursive, removeFile ) +import System.Environment (getArgs, getExecutablePath) +import System.FilePath + ( (), replaceExtension, takeDirectory, takeFileName ) +import System.IO (IOMode(..), hClose, openFile) +import System.IO.Error (isDoesNotExistError) +import System.Process (showCommandForUser) + +import Distribution.Compat.Environment + ( lookupEnv, setEnv, unsetEnv ) +import Distribution.Compat.Semigroup + +import Distribution.Verbosity + +import Distribution.Simple.Program + ( Program(..), ProgramDb + , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput + , runDbProgram, simpleProgram ) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) + +import Distribution.Client.Config (SavedConfig(..)) +import Distribution.Client.GlobalFlags (GlobalFlags(..)) +import Distribution.Client.Sandbox.Types (UseSandbox(..)) + + +configureOneProgram :: Verbosity -> Program -> IO ProgramDb +configureOneProgram verb prog = + configureProgram verb prog (addKnownProgram prog emptyProgramDb) + + +touchFile :: FilePath -> IO () +touchFile path = do + catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) + createDirectoryIfMissing True (takeDirectory path) + openFile path WriteMode >>= hClose + + +findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) +findNixExpr globalFlags config = do + -- criteria for deciding to run nix-shell + let nixEnabled = + fromFlagOrDefault False + (globalNix (savedGlobalFlags config) <> globalNix globalFlags) + + if nixEnabled + then do + let exprPaths = [ "shell.nix", "default.nix" ] + filterM doesFileExist exprPaths >>= \case + [] -> return Nothing + (path : _) -> return (Just path) + else return Nothing + + +-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell +inFakeNixShell :: IO a -> IO a +inFakeNixShell f = + bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) + where + fakeEnv var new = do + old <- lookupEnv var + setEnv var new + return old + resetEnv var = maybe (unsetEnv var) (setEnv var) + + +nixInstantiate + :: Verbosity + -> FilePath + -> Bool + -> GlobalFlags + -> SavedConfig + -> IO () +nixInstantiate verb dist force globalFlags config = + findNixExpr globalFlags config >>= \case + Nothing -> return () + Just shellNix -> do + alreadyInShell <- inNixShell + shellDrv <- drvPath dist shellNix + instantiated <- doesFileExist shellDrv + -- an extra timestamp file is necessary because the derivation lives in + -- the store so its mtime is always 1. + let timestamp = timestampPath dist shellNix + upToDate <- existsAndIsMoreRecentThan timestamp shellNix + + let ready = alreadyInShell || (instantiated && upToDate && not force) + unless ready $ do + + let prog = simpleProgram "nix-instantiate" + progdb <- configureOneProgram verb prog + + removeGCRoots verb dist + touchFile timestamp + + _ <- inFakeNixShell + (getDbProgramOutput verb prog progdb + [ "--add-root", shellDrv, "--indirect", shellNix ]) + return () + + +nixShell + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShell verb dist globalFlags config go = do + + alreadyInShell <- inNixShell + + if alreadyInShell + then go + else do + findNixExpr globalFlags config >>= \case + Nothing -> go + Just shellNix -> do + + let prog = simpleProgram "nix-shell" + progdb <- configureOneProgram verb prog + + cabal <- getExecutablePath + + -- alreadyInShell == True in child process + setEnv "CABAL_IN_NIX_SHELL" "1" + + -- Run cabal with the same arguments inside nix-shell. + -- When the child process reaches the top of nixShell, it will + -- detect that it is running inside the shell and fall back + -- automatically. + shellDrv <- drvPath dist shellNix + args <- getArgs + runDbProgram verb prog progdb + [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv + , "--run", showCommandForUser cabal args + ] + + +drvPath :: FilePath -> FilePath -> IO FilePath +drvPath dist path = do + -- We do not actually care about canonicity, but makeAbsolute is only + -- available in newer versions of directory. + -- We expect the path to be a symlink if it exists, so we do not canonicalize + -- the entire path because that would dereference the symlink. + distNix <- canonicalizePath (dist "nix") + -- Nix garbage collector roots must be absolute paths + return (distNix replaceExtension (takeFileName path) "drv") + + +timestampPath :: FilePath -> FilePath -> FilePath +timestampPath dist path = + dist "nix" replaceExtension (takeFileName path) "drv.timestamp" + + +gcrootPath :: FilePath -> FilePath +gcrootPath dist = dist "nix" "gcroots" + + +inNixShell :: IO Bool +inNixShell = maybe False (const True) <$> lookupEnv "CABAL_IN_NIX_SHELL" + + +removeGCRoots :: Verbosity -> FilePath -> IO () +removeGCRoots verb dist = do + let tgt = gcrootPath dist + exists <- doesDirectoryExist tgt + when exists $ do + debug verb ("removing Nix gcroots from " ++ tgt) + removeDirectoryRecursive tgt + + +nixShellIfSandboxed + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> UseSandbox + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShellIfSandboxed verb dist globalFlags config useSandbox go = + case useSandbox of + NoSandbox -> go + UseSandbox _ -> nixShell verb dist globalFlags config go diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Outdated.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Outdated +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'outdated' command. Checks for outdated +-- dependencies in the package description file or freeze file. +----------------------------------------------------------------------------- + +module Distribution.Client.Outdated ( outdated + , ListOutdatedSettings(..), listOutdated ) +where + +import Prelude () +import Distribution.Client.Config +import Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Compat.Prelude +import Distribution.Client.ProjectConfig +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad +import Distribution.Client.Setup hiding (quiet) +import Distribution.Client.Targets +import Distribution.Client.Types +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackageIndex +import Distribution.Client.Sandbox.PackageEnvironment + +import Distribution.Package (PackageName, packageVersion) +import Distribution.PackageDescription (buildDepends) +import Distribution.PackageDescription.Configuration (finalizePD) +import Distribution.Simple.Compiler (Compiler, compilerInfo) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils + (die', notice, debug, tryFindPackageDesc) +import Distribution.System (Platform) +import Distribution.Text (display) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) +import Distribution.Types.Dependency + (Dependency(..), depPkgName, simplifyDependency) +import Distribution.Verbosity (Verbosity, silent) +import Distribution.Version + (Version, LowerBound(..), UpperBound(..) + ,asVersionIntervals, majorBoundVersion) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + (readGenericPackageDescription) +#else +import Distribution.PackageDescription.Parse + (readGenericPackageDescription) +#endif + +import qualified Data.Set as S +import System.Directory (getCurrentDirectory) +import System.Exit (exitFailure) +import Control.Exception (throwIO) + +-- | Entry point for the 'outdated' command. +outdated :: Verbosity -> OutdatedFlags -> RepoContext + -> Compiler -> Platform + -> IO () +outdated verbosity0 outdatedFlags repoContext comp platform = do + let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) + newFreezeFile = fromFlagOrDefault False + (outdatedNewFreezeFile outdatedFlags) + simpleOutput = fromFlagOrDefault False (outdatedSimpleOutput outdatedFlags) + quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) + exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) + ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) + in \pkgname -> pkgname `S.member` ignoreSet + minorPred = case outdatedMinor outdatedFlags of + Nothing -> const False + Just IgnoreMajorVersionBumpsNone -> const False + Just IgnoreMajorVersionBumpsAll -> const True + Just (IgnoreMajorVersionBumpsSome pkgs) -> + let minorSet = S.fromList pkgs + in \pkgname -> pkgname `S.member` minorSet + verbosity = if quiet then silent else verbosity0 + + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext + let pkgIndex = packageIndex sourcePkgDb + deps <- if freezeFile + then depsFromFreezeFile verbosity + else if newFreezeFile + then depsFromNewFreezeFile verbosity + else depsFromPkgDesc verbosity comp platform + debug verbosity $ "Dependencies loaded: " + ++ (intercalate ", " $ map display deps) + let outdatedDeps = listOutdated deps pkgIndex + (ListOutdatedSettings ignorePred minorPred) + when (not quiet) $ + showResult verbosity outdatedDeps simpleOutput + if (exitCode && (not . null $ outdatedDeps)) + then exitFailure + else return () + +-- | Print either the list of all outdated dependencies, or a message +-- that there are none. +showResult :: Verbosity -> [(Dependency,Version)] -> Bool -> IO () +showResult verbosity outdatedDeps simpleOutput = + if (not . null $ outdatedDeps) + then + do when (not simpleOutput) $ + notice verbosity "Outdated dependencies:" + for_ outdatedDeps $ \(d@(Dependency pn _), v) -> + let outdatedDep = if simpleOutput then display pn + else display d ++ " (latest: " ++ display v ++ ")" + in notice verbosity outdatedDep + else notice verbosity "All dependencies are up to date." + +-- | Convert a list of 'UserConstraint's to a 'Dependency' list. +userConstraintsToDependencies :: [UserConstraint] -> [Dependency] +userConstraintsToDependencies ucnstrs = + mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs + +-- | Read the list of dependencies from the freeze file. +depsFromFreezeFile :: Verbosity -> IO [Dependency] +depsFromFreezeFile verbosity = do + cwd <- getCurrentDirectory + userConfig <- loadUserConfig verbosity cwd Nothing + let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ userConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity "Reading the list of dependencies from the freeze file" + return deps + +-- | Read the list of dependencies from the new-style freeze file. +depsFromNewFreezeFile :: Verbosity -> IO [Dependency] +depsFromNewFreezeFile verbosity = do + projectRoot <- either throwIO return =<< + findProjectRoot Nothing {- TODO: Support '--project-file': -} Nothing + let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing + projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ + readProjectLocalFreezeConfig verbosity distDirLayout + let ucnstrs = map fst . projectConfigConstraints . projectConfigShared + $ projectConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity + "Reading the list of dependencies from the new-style freeze file" + return deps + +-- | Read the list of dependencies from the package description. +depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [Dependency] +depsFromPkgDesc verbosity comp platform = do + cwd <- getCurrentDirectory + path <- tryFindPackageDesc cwd + gpd <- readGenericPackageDescription verbosity path + let cinfo = compilerInfo comp + epd = finalizePD [] (ComponentRequestedSpec True True) + (const True) platform cinfo [] gpd + case epd of + Left _ -> die' verbosity "finalizePD failed" + Right (pd, _) -> do + let bd = buildDepends pd + debug verbosity + "Reading the list of dependencies from the package description" + return bd + +-- | Various knobs for customising the behaviour of 'listOutdated'. +data ListOutdatedSettings = ListOutdatedSettings { + -- | Should this package be ignored? + listOutdatedIgnorePred :: PackageName -> Bool, + -- | Should major version bumps should be ignored for this package? + listOutdatedMinorPred :: PackageName -> Bool + } + +-- | Find all outdated dependencies. +listOutdated :: [Dependency] + -> PackageIndex UnresolvedSourcePackage + -> ListOutdatedSettings + -> [(Dependency, Version)] +listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = + mapMaybe isOutdated $ map simplifyDependency deps + where + isOutdated :: Dependency -> Maybe (Dependency, Version) + isOutdated dep + | ignorePred (depPkgName dep) = Nothing + | otherwise = + let this = map packageVersion $ lookupDependency pkgIndex dep + latest = lookupLatest dep + in (\v -> (dep, v)) `fmap` isOutdated' this latest + + isOutdated' :: [Version] -> [Version] -> Maybe Version + isOutdated' [] _ = Nothing + isOutdated' _ [] = Nothing + isOutdated' this latest = let this' = maximum this + latest' = maximum latest + in if this' < latest' then Just latest' else Nothing + + lookupLatest :: Dependency -> [Version] + lookupLatest dep + | minorPred (depPkgName dep) = + map packageVersion $ lookupDependency pkgIndex (relaxMinor dep) + | otherwise = + map packageVersion $ lookupPackageName pkgIndex (depPkgName dep) + + relaxMinor :: Dependency -> Dependency + relaxMinor (Dependency pn vr) = (Dependency pn vr') + where + vr' = let vis = asVersionIntervals vr + (LowerBound v0 _,upper) = last vis + in case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | Functions to calculate nix-style hashes for package ids. -- @@ -29,11 +30,12 @@ ) where import Distribution.Package - ( PackageId, PackageIdentifier(..), mkUnitId ) + ( PackageId, PackageIdentifier(..), mkComponentId + , PkgconfigName ) import Distribution.System ( Platform, OS(Windows), buildOS ) import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) + ( FlagAssignment, showFlagValue ) import Distribution.Simple.Compiler ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) , ProfDetailLevel(..), showProfDetailLevel ) @@ -41,8 +43,10 @@ ( PathTemplate, fromPathTemplate ) import Distribution.Text ( display ) +import Distribution.Version import Distribution.Client.Types ( InstalledPackageId ) +import qualified Distribution.Solver.Types.ComponentDeps as CD import qualified Hackage.Security.Client as Sec @@ -50,11 +54,14 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) +import Data.Typeable import Data.Maybe (catMaybes) import Data.List (sortBy, intercalate) +import Data.Map (Map) import Data.Function (on) import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate) @@ -85,7 +92,7 @@ -- hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkUnitId $ + mkComponentId $ display pkgHashPkgId -- to be a bit user friendly ++ "-" ++ showHashValue (hashPackageHashInputs pkghashinputs) @@ -105,12 +112,12 @@ -- in the hash. -- -- Truncating the hash size is disappointing but also technically ok. We --- rely on the hash primarily for collision avoidance not for any securty +-- rely on the hash primarily for collision avoidance not for any security -- properties (at least for now). -- hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkUnitId $ + mkComponentId $ intercalate "-" -- max length now 64 [ truncateStr 14 (display name) @@ -133,7 +140,9 @@ -- data PackageHashInputs = PackageHashInputs { pkgHashPkgId :: PackageId, + pkgHashComponent :: Maybe CD.Component, pkgHashSourceHash :: PackageSourceHash, + pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe Version), pkgHashDirectDeps :: Set InstalledPackageId, pkgHashOtherConfig :: PackageHashConfigInputs } @@ -162,13 +171,13 @@ pkgHashStripLibs :: Bool, pkgHashStripExes :: Bool, pkgHashDebugInfo :: DebugInfoLevel, + pkgHashProgramArgs :: Map String [String], pkgHashExtraLibDirs :: [FilePath], pkgHashExtraFrameworkDirs :: [FilePath], pkgHashExtraIncludeDirs :: [FilePath], pkgHashProgPrefix :: Maybe PathTemplate, pkgHashProgSuffix :: Maybe PathTemplate --- TODO: [required eventually] extra program options -- TODO: [required eventually] pkgHashToolsVersions ? -- TODO: [required eventually] pkgHashToolsExtraOptions ? -- TODO: [research required] and what about docs? @@ -188,8 +197,10 @@ renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString renderPackageHashInputs PackageHashInputs{ pkgHashPkgId, + pkgHashComponent, pkgHashSourceHash, pkgHashDirectDeps, + pkgHashPkgConfigDeps, pkgHashOtherConfig = PackageHashConfigInputs{..} } = @@ -207,9 +218,16 @@ --TODO: [nice to have] ultimately we probably want to put this config info -- into the ghc-pkg db. At that point this should probably be changed to -- use the config file infrastructure so it can be read back in again. - LBS.pack $ unlines $ catMaybes + LBS.pack $ unlines $ catMaybes $ [ entry "pkgid" display pkgHashPkgId + , mentry "component" show pkgHashComponent , entry "src" showHashValue pkgHashSourceHash + , entry "pkg-config-deps" + (intercalate ", " . map (\(pn, mb_v) -> display pn ++ + case mb_v of + Nothing -> "" + Just v -> " " ++ display v) + . Set.toList) pkgHashPkgConfigDeps , entry "deps" (intercalate ", " . map display . Set.toList) pkgHashDirectDeps -- and then all the config @@ -236,17 +254,15 @@ , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix - ] + ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs where entry key format value = Just (key ++ ": " ++ format value) + mentry key format value = fmap (\v -> key ++ ": " ++ format v) value opt key def format value | value == def = Nothing | otherwise = entry key format value - showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst) - where - showEntry (FlagName name, False) = '-' : name - showEntry (FlagName name, True) = '+' : name + showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) ----------------------------------------------- -- The specific choice of hash implementation @@ -263,7 +279,7 @@ -- package ids. newtype HashValue = HashValue BS.ByteString - deriving (Eq, Show) + deriving (Eq, Show, Typeable) instance Binary HashValue where put (HashValue digest) = put digest diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs deleted file mode 100644 --- a/Distribution/Client/PackageIndex.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Client.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - elemByPackageId, - elemByPackageName, - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - ) where - -import Prelude hiding (lookup) -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.List (groupBy, sortBy, isInfixOf) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) -#endif -import Data.Maybe (isJust, fromMaybe) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary) -import Distribution.Compat.Semigroup (Semigroup((<>))) - -import Distribution.Package - ( PackageName(..), PackageIdentifier(..) - , Package(..), packageName, packageVersion - , Dependency(Dependency) ) -import Distribution.Version - ( withinRange ) -import Distribution.Simple.Utils - ( lowercase, comparing ) - - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched efficiently by package name and version. --- -newtype PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - - deriving (Eq, Show, Read, Functor, Generic) ---FIXME: the Functor instance here relies on no package id changes - -instance Package pkg => Semigroup (PackageIndex pkg) where - (<>) = merge - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex Map.empty - mappend = (<>) - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = foldr1 mappend xs - -instance Binary pkg => Binary (PackageIndex pkg) - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - --- --- * Internal helpers --- - -mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-sensitively. --- -lookup :: PackageIndex pkg -> PackageName -> [pkg] -lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg -deleteDependency (Dependency name verstionRange) = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = Map.elems m - --- --- * Lookups --- - -elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool -elemByPackageId index = isJust . lookupPackageId index - -elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool -elemByPackageName index = not . null . lookupPackageName index - - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] -lookupDependency index (Dependency name versionRange) = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insensitively to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insensitively but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insensitively and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByName (PackageIndex m) name = - [ pkgs - | pkgs@(PackageName name',_) <- Map.toList m - , lowercase name' == lname ] - where - lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex pkg - -> String -> [(PackageName, [pkg])] -searchByNameSubstring (PackageIndex m) searchterm = - [ pkgs - | pkgs@(PackageName name, _) <- Map.toList m - , lsearchterm `isInfixOf` lowercase name ] - where - lsearchterm = lowercase searchterm diff --git a/Distribution/Client/PackageUtils.hs b/Distribution/Client/PackageUtils.hs --- a/Distribution/Client/PackageUtils.hs +++ b/Distribution/Client/PackageUtils.hs @@ -15,11 +15,13 @@ ) where import Distribution.Package - ( packageVersion, packageName, Dependency(..) ) + ( packageVersion, packageName ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName import Distribution.PackageDescription - ( PackageDescription(..) ) + ( PackageDescription(..), libName ) import Distribution.Version - ( withinRange ) + ( withinRange, isAnyVersion ) -- | The list of dependencies that refer to external packages -- rather than internal package components. @@ -30,5 +32,7 @@ -- True if this dependency is an internal one (depends on a library -- defined in the same package). internal (Dependency depName versionRange) = - depName == packageName pkg && - packageVersion pkg `withinRange` versionRange + (depName == packageName pkg && + packageVersion pkg `withinRange` versionRange) || + (Just (packageNameToUnqualComponentName depName) `elem` map libName (subLibraries pkg) && + isAnyVersion versionRange) diff --git a/Distribution/Client/PkgConfigDb.hs b/Distribution/Client/PkgConfigDb.hs deleted file mode 100644 --- a/Distribution/Client/PkgConfigDb.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PkgConfigDb --- Copyright : (c) Iñaki García Etxebarria 2016 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Read the list of packages available to pkg-config. ------------------------------------------------------------------------------ -module Distribution.Client.PkgConfigDb - ( PkgConfigDb - , readPkgConfigDb - , pkgConfigDbFromList - , pkgConfigPkgIsPresent - , getPkgConfigDbDirs - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -#endif - -import Control.Exception (IOException, handle) -import Data.Char (isSpace) -import qualified Data.Map as M -import Data.Version (parseVersion) -import Text.ParserCombinators.ReadP (readP_to_S) -import System.FilePath (splitSearchPath) - -import Distribution.Package - ( PackageName(..) ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Version - ( Version, VersionRange, withinRange ) - -import Distribution.Compat.Environment - ( lookupEnv ) -import Distribution.Simple.Program - ( ProgramConfiguration, pkgConfigProgram, getProgramOutput, - requireProgram ) -import Distribution.Simple.Utils - ( info ) - --- | The list of packages installed in the system visible to --- @pkg-config@. This is an opaque datatype, to be constructed with --- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. -data PkgConfigDb = PkgConfigDb (M.Map PackageName (Maybe Version)) - -- ^ If an entry is `Nothing`, this means that the - -- package seems to be present, but we don't know the - -- exact version (because parsing of the version - -- number failed). - | NoPkgConfigDb - -- ^ For when we could not run pkg-config successfully. - deriving (Show) - --- | Query pkg-config for the list of installed packages, together --- with their versions. Return a `PkgConfigDb` encapsulating this --- information. -readPkgConfigDb :: Verbosity -> ProgramConfiguration -> IO PkgConfigDb -readPkgConfigDb verbosity conf = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig - ("--modversion" : pkgNames) - (return . pkgConfigDbFromList . zip pkgNames) pkgVersions - where - -- For when pkg-config invocation fails (possibly because of a - -- too long command line). - ioErrorHandler :: IOException -> IO PkgConfigDb - ioErrorHandler e = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ show e) - return NoPkgConfigDb - --- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. -pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb -pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs - where - convert :: (String, String) -> (PackageName, Maybe Version) - convert (n,vs) = (PackageName n, - case (reverse . readP_to_S parseVersion) vs of - (v, "") : _ -> Just v - _ -> Nothing -- Version not (fully) - -- understood. - ) - --- | Check whether a given package range is satisfiable in the given --- @pkg-config@ database. -pkgConfigPkgIsPresent :: PkgConfigDb -> PackageName -> VersionRange -> Bool -pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = - case M.lookup pn db of - Nothing -> False -- Package not present in the DB. - Just Nothing -> True -- Package present, but version unknown. - Just (Just v) -> withinRange v vr --- If we could not read the pkg-config database successfully we allow --- the check to succeed. The plan found by the solver may fail to be --- executed later on, but we have no grounds for rejecting the plan at --- this stage. -pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True - - --- | Query pkg-config for the locations of pkg-config's package files. Use this --- to monitor for changes in the pkg-config DB. --- -getPkgConfigDbDirs :: Verbosity -> ProgramConfiguration -> IO [FilePath] -getPkgConfigDbDirs verbosity conf = - (++) <$> getEnvPath <*> getDefPath - where - -- According to @man pkg-config@: - -- - -- PKG_CONFIG_PATH - -- A colon-separated (on Windows, semicolon-separated) list of directories - -- to search for .pc files. The default directory will always be searched - -- after searching the path - -- - getEnvPath = maybe [] parseSearchPath - <$> lookupEnv "PKG_CONFIG_PATH" - - -- Again according to @man pkg-config@: - -- - -- pkg-config can be used to query itself for the default search path, - -- version number and other information, for instance using: - -- - -- > pkg-config --variable pc_path pkg-config - -- - getDefPath = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf - parseSearchPath <$> - getProgramOutput verbosity pkgConfig - ["--variable", "pc_path", "pkg-config"] - - parseSearchPath str = - case lines str of - [p] | not (null p) -> splitSearchPath p - _ -> [] - - ioErrorHandler :: IOException -> IO [FilePath] - ioErrorHandler _e = return [] - diff --git a/Distribution/Client/PlanIndex.hs b/Distribution/Client/PlanIndex.hs deleted file mode 100644 --- a/Distribution/Client/PlanIndex.hs +++ /dev/null @@ -1,289 +0,0 @@ --- | These graph traversal functions mirror the ones in Cabal, but work with --- the more complete (and fine-grained) set of dependencies provided by --- PackageFixedDeps rather than only the library dependencies provided by --- PackageInstalled. -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Distribution.Client.PlanIndex ( - -- * FakeMap and related operations - FakeMap - , fakeDepends - , fakeLookupUnitId - -- * Graph traversal functions - , brokenPackages - , dependencyCycles - , dependencyGraph - , dependencyInconsistencies - ) where - -import Prelude hiding (lookup) -import qualified Data.Map as Map -import qualified Data.Graph as Graph -import Data.Array ((!)) -import Data.Map (Map) -import Data.Maybe (isNothing) -import Data.Either (rights) - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) -#endif - -import Distribution.Package - ( PackageName(..), PackageIdentifier(..), UnitId(..) - , Package(..), packageName, packageVersion - ) -import Distribution.Version - ( Version ) - -import Distribution.Client.ComponentDeps (ComponentDeps) -import qualified Distribution.Client.ComponentDeps as CD -import Distribution.Client.Types - ( PackageFixedDeps(..) ) -import Distribution.Simple.PackageIndex - ( PackageIndex, allPackages, insert, lookupUnitId ) -import Distribution.Package - ( HasUnitId(..), PackageId ) - --- Note [FakeMap] ------------------ --- We'd like to use the PackageIndex defined in this module for cabal-install's --- InstallPlan. However, at the moment, this data structure is indexed by --- UnitId, which we don't know until after we've compiled a package --- (whereas InstallPlan needs to store not-compiled packages in the index.) --- Eventually, an UnitId will be calculatable prior to actually building --- the package, but at the moment, the "fake installed package ID map" is a --- workaround to solve this problem while reusing PackageIndex. The basic idea --- is that, since we don't know what an UnitId is beforehand, we just fake --- up one based on the package ID (it only needs to be unique for the particular --- install plan), and fill it out with the actual generated UnitId after --- the package is successfully compiled. --- --- However, there is a problem: in the index there may be references using the --- old package ID, which are now dangling if we update the UnitId. We --- could map over the entire index to update these pointers as well (a costly --- operation), but instead, we've chosen to parametrize a variety of important --- functions by a FakeMap, which records what a fake installed package ID was --- actually resolved to post-compilation. If we do a lookup, we first check and --- see if it's a fake ID in the FakeMap. --- --- It's a bit grungy, but we expect this to only be temporary anyway. (Another --- possible workaround would have been to *not* update the installed package ID, --- but I decided this would be hard to understand.) - --- | Map from fake package keys to real ones. See Note [FakeMap] -type FakeMap = Map UnitId UnitId - --- | Variant of `depends` which accepts a `FakeMap` --- --- Analogous to `fakeInstalledDepends`. See Note [FakeMap]. -fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId] -fakeDepends fakeMap = fmap (map resolveFakeId) . depends - where - resolveFakeId :: UnitId -> UnitId - resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap - ---- | Variant of 'lookupUnitId' which accepts a 'FakeMap'. See Note ---- [FakeMap]. -fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId - -> Maybe a -fakeLookupUnitId fakeMap index pkg = - lookupUnitId index (Map.findWithDefault pkg pkg fakeMap) - --- | All packages that have dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: (PackageFixedDeps pkg) - => FakeMap - -> PackageIndex pkg - -> [(pkg, [UnitId])] -brokenPackages fakeMap index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = - [ pkg' | pkg' <- CD.flatDeps (depends pkg) - , isNothing (fakeLookupUnitId fakeMap index pkg') ] - , not (null missing) ] - --- | Compute all roots of the install plan, and verify that the transitive --- plans from those roots are all consistent. --- --- NOTE: This does not check for dependency cycles. Moreover, dependency cycles --- may be absent from the subplans even if the larger plan contains a dependency --- cycle. Such cycles may or may not be an issue; either way, we don't check --- for them here. -dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap - -> Bool - -> PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies fakeMap indepGoals index = - concatMap (dependencyInconsistencies' fakeMap) subplans - where - subplans :: [PackageIndex pkg] - subplans = rights $ - map (dependencyClosure fakeMap index) - (rootSets fakeMap indepGoals index) - --- | Compute the root sets of a plan --- --- A root set is a set of packages whose dependency closure must be consistent. --- This is the set of all top-level library roots (taken together normally, or --- as singletons sets if we are considering them as independent goals), along --- with all setup dependencies of all packages. -rootSets :: (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]] -rootSets fakeMap indepGoals index = - if indepGoals then map (:[]) libRoots else [libRoots] - ++ setupRoots index - where - libRoots = libraryRoots fakeMap index - --- | Compute the library roots of a plan --- --- The library roots are the set of packages with no reverse dependencies --- (no reverse library dependencies but also no reverse setup dependencies). -libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap -> PackageIndex pkg -> [UnitId] -libraryRoots fakeMap index = - map toPkgId roots - where - (graph, toPkgId, _) = dependencyGraph fakeMap index - indegree = Graph.indegree graph - roots = filter isRoot (Graph.vertices graph) - isRoot v = indegree ! v == 0 - --- | The setup dependencies of each package in the plan -setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]] -setupRoots = filter (not . null) - . map (CD.setupDeps . depends) - . allPackages - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies' :: forall pkg. - (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap - -> PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies' fakeMap index = - [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) - ] - where - -- For each package name (of a dependency, somewhere) - -- and each installed ID of that that package - -- the associated package instance - -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId])) - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))]) - | -- For each package @pkg@ - pkg <- allPackages index - -- Find out which @ipid@ @pkg@ depends on - , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg) - -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@) - , Just dep <- [fakeLookupUnitId fakeMap index ipid] - ] - - -- If, in a single install plan, we depend on more than one version of a - -- package, then this is ONLY okay in the (rather special) case that we - -- depend on precisely two versions of that package, and one of them - -- depends on the other. This is necessary for example for the base where - -- we have base-3 depending on base-4. - reallyIsInconsistent :: [pkg] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = installedUnitId p1 - pid2 = installedUnitId p2 - in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2) - && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1) - reallyIsInconsistent _ = True - - - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap - -> PackageIndex pkg - -> [[pkg]] -dependencyCycles fakeMap index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, installedUnitId pkg, - CD.flatDeps (fakeDepends fakeMap pkg)) - | pkg <- allPackages index ] - - --- | Tries to take the transitive closure of the package dependencies. --- --- If the transitive closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageIdentifier's do not occur in the index. -dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap - -> PackageIndex pkg - -> [UnitId] - -> Either [(pkg, [UnitId])] - (PackageIndex pkg) -dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Right completed - (completed, _) -> Left (brokenPackages fakeMap completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = - case fakeLookupUnitId fakeMap index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> - case fakeLookupUnitId fakeMap completed - (installedUnitId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = CD.nonSetupDeps (depends pkg) ++ pkgids - - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg) - => FakeMap - -> PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> UnitId, - UnitId -> Maybe Graph.Vertex) -dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex) - where - (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges - vertexToPkg v = case vertexToPkg' v of - ((), pkgid, _targets) -> pkgid - - pkgs = allPackages index - edges = map edgesFrom pkgs - - resolve pid = Map.findWithDefault pid pid fakeMap - edgesFrom pkg = ( () - , resolve (installedUnitId pkg) - , CD.flatDeps (fakeDepends fakeMap pkg) - ) diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -1,1292 +1,1328 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns, - DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables #-} - --- | --- -module Distribution.Client.ProjectBuilding ( - BuildStatus(..), - BuildStatusMap, - BuildStatusRebuild(..), - BuildReason(..), - MonitorChangedReason(..), - rebuildTargetsDryRun, - rebuildTargets - ) where - -import Distribution.Client.PackageHash (renderPackageHashInputs) -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - -import Distribution.Client.Types - ( PackageLocation(..), GenericReadyPackage(..) - , PackageFixedDeps(..) - , InstalledPackageId, installedPackageId ) -import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.ComponentDeps as CD -import Distribution.Client.ComponentDeps (ComponentDeps) -import Distribution.Client.DistDirLayout -import Distribution.Client.FileMonitor -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import Distribution.Client.GlobalFlags (RepoContext) -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Setup (filterConfigureFlags) -import Distribution.Client.SrcDist (allPackageSourceFiles) -import Distribution.Client.Utils (removeExistingFile) - -import Distribution.Package hiding (InstalledPackageId, installedPackageId) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.Program -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Command (CommandUI) -import qualified Distribution.Simple.Register as Cabal -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.LocalBuildInfo (ComponentName) - -import Distribution.Simple.Utils hiding (matchFileGlob) -import Distribution.Version -import Distribution.Verbosity -import Distribution.Text -import Distribution.ParseUtils ( showPWarning ) - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.ByteString.Lazy as LBS - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad -import Control.Exception -import Control.Concurrent.Async -import Control.Concurrent.MVar -import Data.List -import Data.Maybe - -import System.FilePath -import System.IO -import System.Directory -import System.Exit (ExitCode) - - ------------------------------------------------------------------------------- --- * Overall building strategy. ------------------------------------------------------------------------------- --- --- We start with an 'ElaboratedInstallPlan' that has already been improved by --- reusing packages from the store. So the remaining packages in the --- 'InstallPlan.Configured' state are ones we either need to build or rebuild. --- --- First, we do a preliminary dry run phase where we work out which packages --- we really need to (re)build, and for the ones we do need to build which --- build phase to start at. - - ------------------------------------------------------------------------------- --- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? ------------------------------------------------------------------------------- - --- We split things like this for a couple reasons. Firstly we need to be able --- to do dry runs, and these need to be reasonably accurate in terms of --- letting users know what (and why) things are going to be (re)built. --- --- Given that we need to be able to do dry runs, it would not be great if --- we had to repeat all the same work when we do it for real. Not only is --- it duplicate work, but it's duplicate code which is likely to get out of --- sync. So we do things only once. We preserve info we discover in the dry --- run phase and rely on it later when we build things for real. This also --- somewhat simplifies the build phase. So this way the dry run can't so --- easily drift out of sync with the real thing since we're relying on the --- info it produces. --- --- An additional advantage is that it makes it easier to debug rebuild --- errors (ie rebuilding too much or too little), since all the rebuild --- decisions are made without making any state changes at the same time --- (that would make it harder to reproduce the problem sitation). - - --- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan' --- -type BuildStatusMap = Map InstalledPackageId BuildStatus - --- | The build status for an individual package. That is, the state that the --- package is in prior to initiating a (re)build. --- --- It serves two purposes: --- --- * For dry-run output, it lets us explain to the user if and why a package --- is going to be (re)built. --- --- * It tell us what step to start or resume building from, and carries --- enough information for us to be able to do so. --- -data BuildStatus = - - -- | The package is in the 'InstallPlan.PreExisting' state, so does not - -- need building. - BuildStatusPreExisting - - -- | The package has not been downloaded yet, so it will have to be - -- downloaded, unpacked and built. - | BuildStatusDownload - - -- | The package has not been unpacked yet, so it will have to be - -- unpacked and built. - | BuildStatusUnpack FilePath - - -- | The package exists in a local dir already, and just needs building - -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style - -- packages. - | BuildStatusRebuild FilePath BuildStatusRebuild - - -- | The package exists in a local dir already, and is fully up to date. - -- So this package can be put into the 'InstallPlan.Installed' state - -- and it does not need to be built. - | BuildStatusUpToDate (Maybe InstalledPackageInfo) BuildSuccess - --- | For a package that is going to be built or rebuilt, the state it's in now. --- --- So again, this tells us why a package needs to be rebuilt and what build --- phases need to be run. The 'MonitorChangedReason' gives us details like --- which file changed, which is mainly for high verbosity debug output. --- -data BuildStatusRebuild = - - -- | The package configuration changed, so the configure and build phases - -- needs to be (re)run. - BuildStatusConfigure (MonitorChangedReason ()) - - -- | The configuration has not changed but the build phase needs to be - -- rerun. We record the reason the (re)build is needed. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we stil need to do that after building. - -- - | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason - -data BuildReason = - -- | The depencencies of this package have been (re)built so the build - -- phase needs to be rerun. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we stil need to do that after building. - -- - BuildReasonDepsRebuilt - - -- | Changes in files within the package (or first run or corrupt cache) - | BuildReasonFilesChanged (MonitorChangedReason ()) - - -- | An important special case is that no files have changed but the - -- set of components the /user asked to build/ has changed. We track the - -- set of components /we have built/, which of course only grows (until - -- some other change resets it). - -- - -- The @Set 'ComponentName'@ is the set of components we have built - -- previously. When we update the monitor we take the union of the ones - -- we have built previously with the ones the user has asked for this - -- time and save those. See 'updatePackageBuildFileMonitor'. - -- - | BuildReasonExtraTargets (Set ComponentName) - - -- | Although we're not going to build any additional targets as a whole, - -- we're going to build some part of a component or run a repl or any - -- other action that does not result in additional persistent artifacts. - -- - | BuildReasonEphemeralTargets - --- | Which 'BuildStatus' values indicate we'll have to do some build work of --- some sort. In particular we use this as part of checking if any of a --- package's deps have changed. --- -buildStatusRequiresBuild :: BuildStatus -> Bool -buildStatusRequiresBuild BuildStatusPreExisting = False -buildStatusRequiresBuild BuildStatusUpToDate {} = False -buildStatusRequiresBuild _ = True - --- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. --- --- It gives us the 'BuildStatusMap' and also gives us an improved version of --- the 'ElaboratedInstallPlan' with packages switched to the --- 'InstallPlan.Installed' state when we find that they're already up to date. --- -rebuildTargetsDryRun :: DistDirLayout - -> ElaboratedInstallPlan - -> IO (ElaboratedInstallPlan, BuildStatusMap) -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do - - -- Do the various checks to work out the 'BuildStatus' of each package - pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg - - -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as - -- 'InstallPlan.Installed'. - let installPlan' = improveInstallPlanWithUpToDatePackages - installPlan pkgsBuildStatus - - return (installPlan', pkgsBuildStatus) - where - dryRunPkg :: ElaboratedPlanPackage - -> ComponentDeps [BuildStatus] - -> IO BuildStatus - dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = - return BuildStatusPreExisting - - dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do - mloc <- checkFetched (pkgSourceLocation pkg) - case mloc of - Nothing -> return BuildStatusDownload - - Just (LocalUnpackedPackage srcdir) -> - -- For the case of a user-managed local dir, irrespective of the - -- build style, we build from that directory and put build - -- artifacts under the shared dist directory. - dryRunLocalPkg pkg depsBuildStatus srcdir - - -- The three tarball cases are handled the same as each other, - -- though depending on the build style. - Just (LocalTarballPackage tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RemoteTarballPackage _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - Just (RepoTarballPackage _ _ tarball) -> - dryRunTarballPkg pkg depsBuildStatus tarball - - dryRunPkg (InstallPlan.Processing {}) _ = unexpectedState - dryRunPkg (InstallPlan.Installed {}) _ = unexpectedState - dryRunPkg (InstallPlan.Failed {}) _ = unexpectedState - - unexpectedState = error "rebuildTargetsDryRun: unexpected package state" - - dryRunTarballPkg :: ElaboratedConfiguredPackage - -> ComponentDeps [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunTarballPkg pkg depsBuildStatus tarball = - case pkgBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly -> do - -- TODO: [nice to have] use a proper file monitor rather than this dir exists test - exists <- doesDirectoryExist srcdir - if exists - then dryRunLocalPkg pkg depsBuildStatus srcdir - else return (BuildStatusUnpack tarball) - where - srcdir = distUnpackedSrcDirectory (packageId pkg) - - dryRunLocalPkg :: ElaboratedConfiguredPackage - -> ComponentDeps [BuildStatus] - -> FilePath - -> IO BuildStatus - dryRunLocalPkg pkg depsBuildStatus srcdir = do - -- Go and do lots of I/O, reading caches and probing files to work out - -- if anything has changed - change <- checkPackageFileMonitorChanged - packageFileMonitor pkg srcdir depsBuildStatus - case change of - -- It did change, giving us 'BuildStatusRebuild' info on why - Left rebuild -> - return (BuildStatusRebuild srcdir rebuild) - - -- No changes, the package is up to date. Use the saved build results. - Right (mipkg, buildSuccess) -> - return (BuildStatusUpToDate mipkg buildSuccess) - where - packageFileMonitor = - newPackageFileMonitor distDirLayout (packageId pkg) - - --- | A specialised traversal over the packages in an install plan. --- --- The packages are visited in dependency order, starting with packages with no --- depencencies. The result for each package is accumulated into a 'Map' and --- returned as the final result. In addition, when visting a package, the --- visiting function is passed the results for all the immediate package --- depencencies. This can be used to propagate information from depencencies. --- -foldMInstallPlanDepOrder - :: forall m ipkg srcpkg iresult ifailure b. - (Monad m, - HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> (GenericPlanPackage ipkg srcpkg iresult ifailure -> - ComponentDeps [b] -> m b) - -> m (Map InstalledPackageId b) -foldMInstallPlanDepOrder plan0 visit = - go Map.empty (InstallPlan.reverseTopologicalOrder plan0) - where - go :: Map InstalledPackageId b - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] - -> m (Map InstalledPackageId b) - go !results [] = return results - - go !results (pkg : pkgs) = do - -- we go in the right order so the results map has entries for all deps - let depresults :: ComponentDeps [b] - depresults = - fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results - in result)) - (depends pkg) - result <- visit pkg depresults - let results' = Map.insert (installedPackageId pkg) result results - go results' pkgs - -improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan - -> BuildStatusMap - -> ElaboratedInstallPlan -improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = - replaceWithPreInstalled installPlan - [ (installedPackageId pkg, mipkg, buildSuccess) - | InstallPlan.Configured pkg - <- InstallPlan.reverseTopologicalOrder installPlan - , let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus - , BuildStatusUpToDate mipkg buildSuccess <- [pkgBuildStatus] - ] - where - replaceWithPreInstalled = - foldl' (\plan (ipkgid, mipkg, buildSuccess) -> - InstallPlan.preinstalled ipkgid mipkg buildSuccess plan) - - ------------------------------ --- Package change detection --- - --- | As part of the dry run for local unpacked packages we have to check if the --- package config or files have changed. That is the purpose of --- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. --- --- When a package is (re)built, the monitor must be updated to reflect the new --- state of the package. Because we sometimes build without reconfiguring the --- state updates are split into two, one for package config changes and one --- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' --- and 'updatePackageBuildFileMonitor'. --- -data PackageFileMonitor = PackageFileMonitor { - pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), - pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildSuccess, - pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) - } - -newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor -newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid = - PackageFileMonitor { - pkgFileMonitorConfig = - newFileMonitor (distPackageCacheFile pkgid "config"), - - pkgFileMonitorBuild = - FileMonitor { - fileMonitorCacheFile = distPackageCacheFile pkgid "build", - fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> - componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, - fileMonitorCheckIfOnlyValueChanged = True - }, - - pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile pkgid "registration") - } - --- | Helper function for 'checkPackageFileMonitorChanged', --- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. --- --- It selects the info from a 'ElaboratedConfiguredPackage' that are used by --- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. --- -packageFileMonitorKeyValues :: ElaboratedConfiguredPackage - -> (ElaboratedConfiguredPackage, Set ComponentName) -packageFileMonitorKeyValues pkg = - (pkgconfig, buildComponents) - where - -- The first part is the value used to guard (re)configuring the package. - -- That is, if this value changes then we will reconfigure. - -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of - -- information that affects the (re)configure step. But those parts that - -- do not affect the configure step need to be nulled out. Those parts are - -- the specific targets that we're going to build. - -- - pkgconfig = pkg { - pkgBuildTargets = [], - pkgReplTarget = Nothing, - pkgBuildHaddocks = False - } - - -- The second part is the value used to guard the build step. So this is - -- more or less the opposite of the first part, as it's just the info about - -- what targets we're going to build. - -- - buildComponents = pkgBuildTargetWholeComponents pkg - --- | Do all the checks on whether a package has changed and thus needs either --- rebuilding or reconfiguring and rebuilding. --- -checkPackageFileMonitorChanged :: PackageFileMonitor - -> ElaboratedConfiguredPackage - -> FilePath - -> ComponentDeps [BuildStatus] - -> IO (Either BuildStatusRebuild - (Maybe InstalledPackageInfo, - BuildSuccess)) -checkPackageFileMonitorChanged PackageFileMonitor{..} - pkg srcdir depsBuildStatus = do - --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged - configChanged <- checkFileMonitorChanged - pkgFileMonitorConfig srcdir pkgconfig - case configChanged of - MonitorChanged monitorReason -> - return (Left (BuildStatusConfigure monitorReason')) - where - monitorReason' = fmap (const ()) monitorReason - - MonitorUnchanged () _ - -- The configChanged here includes the identity of the dependencies, - -- so depsBuildStatus is just needed for the changes in the content - -- of depencencies. - | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do - regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) - - | otherwise -> do - buildChanged <- checkFileMonitorChanged - pkgFileMonitorBuild srcdir buildComponents - regChanged <- checkFileMonitorChanged - pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - case (buildChanged, regChanged) of - (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonExtraTargets prevBuildComponents - - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> - -- this should only happen if the file is corrupt or been - -- manually deleted. We don't want to bother with another - -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - - (MonitorUnchanged _ _, MonitorUnchanged _ _) - | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonEphemeralTargets - - (MonitorUnchanged buildSuccess _, MonitorUnchanged mipkg _) -> - return (Right (mipkg, buildSuccess)) - where - (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x - - -updatePackageConfigFileMonitor :: PackageFileMonitor - -> FilePath - -> ElaboratedConfiguredPackage - -> IO () -updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} - srcdir pkg = - updateFileMonitor pkgFileMonitorConfig srcdir Nothing - [] pkgconfig () - where - (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg - -updatePackageBuildFileMonitor :: PackageFileMonitor - -> FilePath - -> MonitorTimestamp - -> ElaboratedConfiguredPackage - -> BuildStatusRebuild - -> [FilePath] - -> BuildSuccess - -> IO () -updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} - srcdir timestamp pkg pkgBuildStatus - allSrcFiles buildSuccess = - updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) - (map monitorFileHashed allSrcFiles) - buildComponents' buildSuccess - where - (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - - -- If the only thing that's changed is that we're now building extra - -- components, then we can avoid later unnecessary rebuilds by saving the - -- total set of components that have been built, namely the union of the - -- existing ones plus the new ones. If files also changed this would be - -- the wrong thing to do. Note that we rely on the - -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee - -- that it's /only/ the value that changed not any files that changed. - buildComponents' = - case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) - -> buildComponents `Set.union` prevBuildComponents - _ -> buildComponents - -updatePackageRegFileMonitor :: PackageFileMonitor - -> FilePath - -> Maybe InstalledPackageInfo - -> IO () -updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} - srcdir mipkg = - updateFileMonitor pkgFileMonitorReg srcdir Nothing - [] () mipkg - -invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () -invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) - - ------------------------------------------------------------------------------- --- * Doing it: executing an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - - --- | Build things for real. --- --- It requires the 'BuildStatusMap' gatthered by 'rebuildTargetsDryRun'. --- -rebuildTargets :: Verbosity - -> DistDirLayout - -> ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> BuildStatusMap - -> BuildTimeSettings - -> IO ElaboratedInstallPlan -rebuildTargets verbosity - distDirLayout@DistDirLayout{..} - installPlan - sharedPackageConfig - pkgsBuildStatus - buildSettings@BuildTimeSettings{buildSettingNumJobs} = do - - -- Concurrency control: create the job controller and concurrency limits - -- for downloading, building and installing. - jobControl <- if isParallelBuild then newParallelJobControl - else newSerialJobControl - buildLimit <- newJobLimit buildSettingNumJobs - installLock <- newLock -- serialise installation - cacheLock <- newLock -- serialise access to setup exe cache - --TODO: [code cleanup] eliminate setup exe cache - - createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity False distTempDirectory - - -- Before traversing the install plan, pre-emptively find all packages that - -- will need to be downloaded and start downloading them. - asyncDownloadPackages verbosity withRepoCtx - installPlan pkgsBuildStatus $ \downloadMap -> - - -- For each package in the plan, in dependency order, but in parallel... - executeInstallPlan verbosity jobControl installPlan $ \pkg -> - handle (return . BuildFailure) $ --TODO: review exception handling - - let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in - - rebuildTarget - verbosity - distDirLayout - buildSettings downloadMap - buildLimit installLock cacheLock - sharedPackageConfig - pkg - pkgBuildStatus - where - isParallelBuild = buildSettingNumJobs >= 2 - withRepoCtx = projectConfigWithBuilderRepoContext verbosity - buildSettings - --- | Given all the context and resources, (re)build an individual package. --- -rebuildTarget :: Verbosity - -> DistDirLayout - -> BuildTimeSettings - -> AsyncDownloadMap - -> JobLimit -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedReadyPackage - -> BuildStatus - -> IO BuildResult -rebuildTarget verbosity - distDirLayout@DistDirLayout{distBuildDirectory} - buildSettings downloadMap - buildLimit installLock cacheLock - sharedPackageConfig - rpkg@(ReadyPackage pkg _) - pkgBuildStatus = - - -- We rely on the 'BuildStatus' to decide which phase to start from: - case pkgBuildStatus of - BuildStatusDownload -> downloadPhase - BuildStatusUnpack tarball -> unpackTarballPhase tarball - BuildStatusRebuild srcdir status -> rebuildPhase status srcdir - - -- TODO: perhaps re-nest the types to make these impossible - BuildStatusPreExisting {} -> unexpectedState - BuildStatusUpToDate {} -> unexpectedState - where - unexpectedState = error "rebuildTarget: unexpected package status" - - downloadPhase = do - downsrcloc <- waitAsyncPackageDownload verbosity downloadMap pkg - case downsrcloc of - DownloadedTarball tarball -> unpackTarballPhase tarball - --TODO: [nice to have] git/darcs repos etc - - - unpackTarballPhase tarball = - withJobLimit buildLimit $ - withTarballLocalDirectory - verbosity distDirLayout tarball - (packageId pkg) (pkgBuildStyle pkg) - (pkgDescriptionOverride pkg) $ - - case pkgBuildStyle pkg of - BuildAndInstall -> buildAndInstall - BuildInplaceOnly -> buildInplace buildStatus - where - buildStatus = BuildStatusConfigure MonitorFirstRun - - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- - rebuildPhase buildStatus srcdir = - assert (pkgBuildStyle pkg == BuildInplaceOnly) $ - - withJobLimit buildLimit $ - buildInplace buildStatus srcdir builddir - where - builddir = distBuildDirectory (packageId pkg) - - buildAndInstall srcdir builddir = - buildAndInstallUnpackedPackage - verbosity distDirLayout - buildSettings installLock cacheLock - sharedPackageConfig - rpkg - srcdir builddir' - where - builddir' = makeRelative srcdir builddir - --TODO: [nice to have] ^^ do this relative stuff better - - buildInplace buildStatus srcdir builddir = - --TODO: [nice to have] use a relative build dir rather than absolute - buildInplaceUnpackedPackage - verbosity distDirLayout - buildSettings cacheLock - sharedPackageConfig - rpkg - buildStatus - srcdir builddir - ---TODO: [nice to have] do we need to use a with-style for the temp files for downloading http --- packages, or are we going to cache them persistently? - -type AsyncDownloadMap = Map (PackageLocation (Maybe FilePath)) - (MVar DownloadedSourceLocation) - -data DownloadedSourceLocation = DownloadedTarball FilePath - --TODO: [nice to have] git/darcs repos etc - -downloadedSourceLocation :: PackageLocation FilePath - -> Maybe DownloadedSourceLocation -downloadedSourceLocation pkgloc = - case pkgloc of - RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) - RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) - _ -> Nothing - --- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the --- packages we have to download and fork off an async action to download them. --- We download them in dependency order so that the one's we'll need --- first are the ones we will start downloading first. --- --- The body action is passed a map from those packages (identified by their --- location) to a completion var for that package. So the body action should --- lookup the location and use 'waitAsyncPackageDownload' to get the result. --- -asyncDownloadPackages :: Verbosity - -> ((RepoContext -> IO ()) -> IO ()) - -> ElaboratedInstallPlan - -> BuildStatusMap - -> (AsyncDownloadMap -> IO a) - -> IO a -asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body - | null pkgsToDownload = body Map.empty - | otherwise = do - --TODO: [research required] use parallel downloads? if so, use the fetchLimit - - asyncDownloadVars <- mapM (\loc -> (,) loc <$> newEmptyMVar) pkgsToDownload - - let downloadAction :: IO () - downloadAction = - withRepoCtx $ \repoctx -> - forM_ asyncDownloadVars $ \(pkgloc, var) -> do - Just scrloc <- downloadedSourceLocation <$> - fetchPackage verbosity repoctx pkgloc - putMVar var scrloc - - withAsync downloadAction $ \_ -> - body (Map.fromList asyncDownloadVars) - where - pkgsToDownload = - [ pkgSourceLocation pkg - | InstallPlan.Configured pkg - <- InstallPlan.reverseTopologicalOrder installPlan - , let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus - , BuildStatusDownload <- [pkgBuildStatus] - ] - - --- | Check if a package needs downloading, and if so expect to find a download --- in progress in the given 'AsyncDownloadMap' and wait on it to finish. --- -waitAsyncPackageDownload :: Verbosity - -> AsyncDownloadMap - -> ElaboratedConfiguredPackage - -> IO DownloadedSourceLocation -waitAsyncPackageDownload verbosity downloadMap pkg = - case Map.lookup (pkgSourceLocation pkg) downloadMap of - Just hnd -> do - debug verbosity $ - "Waiting for download of " ++ display (packageId pkg) ++ " to finish" - --TODO: [required eventually] do the exception handling on download stuff - takeMVar hnd - Nothing -> - fail "waitAsyncPackageDownload: package not being download" - - -executeInstallPlan - :: forall ipkg srcpkg iresult. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => Verbosity - -> JobControl IO ( GenericReadyPackage srcpkg ipkg - , GenericBuildResult ipkg iresult BuildFailure ) - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> ( GenericReadyPackage srcpkg ipkg - -> IO (GenericBuildResult ipkg iresult BuildFailure)) - -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure) -executeInstallPlan verbosity jobCtl plan0 installPkg = - tryNewTasks 0 plan0 - where - tryNewTasks taskCount plan = do - case InstallPlan.ready plan of - [] | taskCount == 0 -> return plan - | otherwise -> waitForTasks taskCount plan - pkgs -> do - sequence_ - [ do debug verbosity $ "Ready to install " ++ display pkgid - spawnJob jobCtl $ do - buildResult <- installPkg pkg - return (pkg, buildResult) - | pkg <- pkgs - , let pkgid = packageId pkg - ] - - let taskCount' = taskCount + length pkgs - plan' = InstallPlan.processing pkgs plan - waitForTasks taskCount' plan' - - waitForTasks taskCount plan = do - debug verbosity $ "Waiting for install task to finish..." - (pkg, buildResult) <- collectJob jobCtl - let taskCount' = taskCount-1 - plan' = updatePlan pkg buildResult plan - tryNewTasks taskCount' plan' - - updatePlan :: GenericReadyPackage srcpkg ipkg - -> GenericBuildResult ipkg iresult BuildFailure - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - updatePlan pkg (BuildSuccess mipkg buildSuccess) = - InstallPlan.completed (installedPackageId pkg) mipkg buildSuccess - - updatePlan pkg (BuildFailure buildFailure) = - InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure - where - depsFailure = DependentFailed (packageId pkg) - -- So this first pkgid failed for whatever reason (buildFailure). - -- All the other packages that depended on this pkgid, which we - -- now cannot build, we mark as failing due to 'DependentFailed' - -- which kind of means it was not their fault. - - --- | Ensure that the package is unpacked in an appropriate directory, either --- a temporary one or a persistent one under the shared dist directory. --- -withTarballLocalDirectory - :: Verbosity - -> DistDirLayout - -> FilePath - -> PackageId - -> BuildStyle - -> Maybe CabalFileText - -> (FilePath -> FilePath -> IO a) - -> IO a -withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} - tarball pkgid buildstyle pkgTextOverride - buildPkg = - case buildstyle of - -- In this case we make a temp dir, unpack the tarball to there and - -- build and install it from that temp dir. - BuildAndInstall -> - withTempDirectory verbosity distTempDirectory - (display (packageName pkgid)) $ \tmpdir -> do - unpackPackageTarball verbosity tarball tmpdir - pkgid pkgTextOverride - let srcdir = tmpdir display pkgid - builddir = srcdir "dist" - buildPkg srcdir builddir - - -- In this case we make sure the tarball has been unpacked to the - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory pkgid - -- TODO: [nice to have] use a proper file monitor rather than this dir exists test - exists <- doesDirectoryExist srcdir - unless exists $ do - createDirectoryIfMissingVerbose verbosity False srcrootdir - unpackPackageTarball verbosity tarball srcrootdir - pkgid pkgTextOverride - moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid - buildPkg srcdir builddir - - -unpackPackageTarball :: Verbosity -> FilePath -> FilePath - -> PackageId -> Maybe CabalFileText - -> IO () -unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = - --TODO: [nice to have] switch to tar package and catch tar exceptions - annotateFailure UnpackFailed $ do - - -- Unpack the tarball - -- - info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." - Tar.extractTarGzFile parentdir pkgsubdir tarball - - -- Sanity check - -- - exists <- doesFileExist cabalFile - when (not exists) $ - die $ "Package .cabal file not found in the tarball: " ++ cabalFile - - -- Overwrite the .cabal with the one from the index, when appropriate - -- - case pkgTextOverride of - Nothing -> return () - Just pkgtxt -> do - info verbosity $ "Updating " ++ display pkgname <.> "cabal" - ++ " with the latest revision from the index." - writeFileAtomic cabalFile pkgtxt - - where - cabalFile = parentdir pkgsubdir - display pkgname <.> "cabal" - pkgsubdir = display pkgid - pkgname = packageName pkgid - - --- | This is a bit of a hacky workaround. A number of packages ship --- pre-processed .hs files in a dist directory inside the tarball. We don't --- use the standard 'dist' location so unless we move this dist dir to the --- right place then we'll miss the shipped pre-procssed files. This hacky --- approach to shipped pre-procssed files ought to be replaced by a proper --- system, though we'll still need to keep this hack for older packages. --- -moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> IO () -moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} - parentdir pkgid = do - distDirExists <- doesDirectoryExist tarballDistDir - when distDirExists $ do - debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" - ++ targetDistDir ++ "'" - --TODO: [nice to have] or perhaps better to copy, and use a file monitor - renameDirectory tarballDistDir targetDistDir - where - tarballDistDir = parentdir display pkgid "dist" - targetDistDir = distBuildDirectory pkgid - - -buildAndInstallUnpackedPackage :: Verbosity - -> DistDirLayout - -> BuildTimeSettings -> Lock -> Lock - -> ElaboratedSharedConfig - -> ElaboratedReadyPackage - -> FilePath -> FilePath - -> IO BuildResult -buildAndInstallUnpackedPackage verbosity - DistDirLayout{distTempDirectory} - BuildTimeSettings { - buildSettingNumJobs, - buildSettingLogFile - } - installLock cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - rpkg@(ReadyPackage pkg _deps) - srcdir builddir = do - - createDirectoryIfMissingVerbose verbosity False builddir - initLogFile - - --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like - -- we do for ghc, with a proper options type and rendering step - -- which will also let us call directly into the lib, rather than always - -- going via the lib's command line interface, which would also allow - -- passing data like installed packages, compiler, and program db for a - -- quicker configure. - - --TODO: [required feature] docs and tests - --TODO: [required feature] sudo re-exec - - -- Configure phase - when isParallelBuild $ - notice verbosity $ "Configuring " ++ display pkgid ++ "..." - annotateFailure ConfigureFailed $ - setup configureCommand configureFlags - - -- Build phase - when isParallelBuild $ - notice verbosity $ "Building " ++ display pkgid ++ "..." - annotateFailure BuildFailed $ - setup buildCommand buildFlags - - -- Install phase - mipkg <- - criticalSection installLock $ - annotateFailure InstallFailed $ do - --TODO: [research required] do we need the installLock for copying? can we not do that in - -- parallel? Isn't it just registering that we have to lock for? - - --TODO: [required eventually] need to lock installing this ipkig so other processes don't - -- stomp on our files, since we don't have ABI compat, not safe to replace - - -- TODO: [required eventually] note that for nix-style installations it is not necessary to do - -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a - -- shared bin dir. - - -- Actual installation - setup Cabal.copyCommand copyFlags - - LBS.writeFile - (InstallDirs.prefix (pkgInstallDirs pkg) "cabal-hash.txt") $ - (renderPackageHashInputs (packageHashInputs pkgshared pkg)) - - -- here's where we could keep track of the installed files ourselves if - -- we wanted by calling copy to an image dir and then we would make a - -- manifest and move it to its final location - - --TODO: [nice to have] we should actually have it make an image in store/incomming and - -- then when it's done, move it to its final location, to reduce problems - -- with installs failing half-way. Could also register and then move. - - -- For libraries, grab the package configuration file - -- and register it ourselves - if pkgRequiresRegistration pkg - then do - ipkg <- generateInstalledPackageInfo - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - let ipkg' = ipkg { Installed.installedUnitId = ipkgid } - Cabal.registerPackage verbosity compiler progdb - True -- multi-instance, nix style - (pkgRegisterPackageDBStack pkg) ipkg' - return (Just ipkg') - else return Nothing - - --TODO: [required feature] docs and test phases - let docsResult = DocsNotTried - testsResult = TestsNotTried - - return (BuildSuccess mipkg (BuildOk docsResult testsResult)) - - where - pkgid = packageId rpkg - ipkgid = installedPackageId rpkg - - isParallelBuild = buildSettingNumJobs >= 2 - - configureCommand = Cabal.configureCommand defaultProgramConfiguration - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - - buildCommand = Cabal.buildCommand defaultProgramConfiguration - buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfFile -> do - -- make absolute since setup changes dir - pkgConfFile' <- canonicalizePath pkgConfFile - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfFile' - setup Cabal.registerCommand registerFlags - - copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir - - scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir - isParallelBuild cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = - withLogging $ \mLogFileHandle -> - setupWrapper - verbosity - scriptOptions { useLoggingHandle = mLogFileHandle } - (Just (pkgDescription pkg)) - cmd flags [] - - mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid) - - initLogFile = - case mlogFile of - Nothing -> return () - Just logFile -> do - createDirectoryIfMissing True (takeDirectory logFile) - exists <- doesFileExist logFile - when exists $ removeFile logFile - - withLogging action = - case mlogFile of - Nothing -> action Nothing - Just logFile -> withFile logFile AppendMode (action . Just) - - -buildInplaceUnpackedPackage :: Verbosity - -> DistDirLayout - -> BuildTimeSettings -> Lock - -> ElaboratedSharedConfig - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> FilePath -> FilePath - -> IO BuildResult -buildInplaceUnpackedPackage verbosity - distDirLayout@DistDirLayout { - distTempDirectory, - distPackageCacheDirectory - } - BuildTimeSettings{buildSettingNumJobs} - cacheLock - pkgshared@ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } - rpkg@(ReadyPackage pkg _deps) - buildStatus - srcdir builddir = do - - --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here - -- builddir is not enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity False builddir - createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid) - createPackageDBIfMissing verbosity compiler progdb (pkgBuildPackageDBStack pkg) - - -- Configure phase - -- - whenReConfigure $ do - annotateFailure ConfigureFailed $ - setup configureCommand configureFlags [] - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg - - -- Build phase - -- - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildSuccess :: BuildSuccess - buildSuccess = BuildOk docsResult testsResult - - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - annotateFailure BuildFailed $ - setup buildCommand buildFlags buildArgs - - --TODO: [required eventually] this doesn't track file - --non-existence, so we could fail to rebuild if someone - --adds a new file which changes behavior. - allSrcFiles <- allPackageSourceFiles verbosity srcdir - - updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp - pkg buildStatus - allSrcFiles buildSuccess - - mipkg <- whenReRegister $ annotateFailure InstallFailed $ do - -- Register locally - mipkg <- if pkgRequiresRegistration pkg - then do - ipkg <- generateInstalledPackageInfo - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - let ipkg' = ipkg { Installed.installedUnitId = ipkgid } - Cabal.registerPackage verbosity compiler progdb False - (pkgRegisterPackageDBStack pkg) - ipkg' - return (Just ipkg') - - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg - return mipkg - - -- Repl phase - -- - whenRepl $ - annotateFailure BuildFailed $ - setup replCommand replFlags replArgs - - -- Haddock phase - whenHaddock $ - annotateFailure BuildFailed $ - setup haddockCommand haddockFlags [] - - return (BuildSuccess mipkg buildSuccess) - - where - pkgid = packageId rpkg - ipkgid = installedPackageId rpkg - - isParallelBuild = buildSettingNumJobs >= 2 - - packageFileMonitor = newPackageFileMonitor distDirLayout pkgid - - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - - whenRebuild action - | null (pkgBuildTargets pkg) = return () - | otherwise = action - - whenRepl action - | isNothing (pkgReplTarget pkg) = return () - | otherwise = action - - whenHaddock action - | pkgBuildHaddocks pkg = action - | otherwise = return () - - whenReRegister action = case buildStatus of - BuildStatusConfigure _ -> action - BuildStatusBuild Nothing _ -> action - BuildStatusBuild (Just mipkg) _ -> return mipkg - - configureCommand = Cabal.configureCommand defaultProgramConfiguration - configureFlags v = flip filterConfigureFlags v $ - setupHsConfigureFlags rpkg pkgshared - verbosity builddir - - buildCommand = Cabal.buildCommand defaultProgramConfiguration - buildFlags _ = setupHsBuildFlags pkg pkgshared - verbosity builddir - buildArgs = setupHsBuildArgs pkg - - replCommand = Cabal.replCommand defaultProgramConfiguration - replFlags _ = setupHsReplFlags pkg pkgshared - verbosity builddir - replArgs = setupHsReplArgs pkg - - haddockCommand = Cabal.haddockCommand - haddockFlags _ = setupHsHaddockFlags pkg pkgshared - verbosity builddir - - scriptOptions = setupHsScriptOptions rpkg pkgshared - srcdir builddir - isParallelBuild cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO () - setup cmd flags args = - setupWrapper verbosity - scriptOptions - (Just (pkgDescription pkg)) - cmd flags args - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity distTempDirectory $ \pkgConfFile -> do - -- make absolute since setup changes dir - pkgConfFile' <- canonicalizePath pkgConfFile - let registerFlags _ = setupHsRegisterFlags - pkg pkgshared - verbosity builddir - pkgConfFile' - setup Cabal.registerCommand registerFlags [] - - --- helper -annotateFailure :: (String -> BuildFailure) -> IO a -> IO a -annotateFailure annotate action = - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] - where - handler :: Exception e => e -> IO a - handler = throwIO . annotate -#if MIN_VERSION_base(4,8,0) - . displayException -#else - . show -#endif - - -withTempInstalledPackageInfoFile :: Verbosity -> FilePath - -> (FilePath -> IO ()) - -> IO InstalledPackageInfo -withTempInstalledPackageInfoFile verbosity tempdir action = - withTempFile tempdir "package-registration-" $ \pkgConfFile hnd -> do - hClose hnd - action pkgConfFile - - (warns, ipkg) <- withUTF8FileContents pkgConfFile $ \pkgConfStr -> - case Installed.parseInstalledPackageInfo pkgConfStr of - Installed.ParseFailed perror -> pkgConfParseFailed perror - Installed.ParseOk warns ipkg -> return (warns, ipkg) - - unless (null warns) $ - warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) - - return ipkg - where - pkgConfParseFailed :: Installed.PError -> IO a - pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" - ++ show perror + ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- +module Distribution.Client.ProjectBuilding ( + -- * Dry run phase + -- | What bits of the plan will we execute? The dry run does not change + -- anything but tells us what will need to be built. + rebuildTargetsDryRun, + improveInstallPlanWithUpToDatePackages, + + -- ** Build status + -- | This is the detailed status information we get from the dry run. + BuildStatusMap, + BuildStatus(..), + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + buildStatusToString, + + -- * Build phase + -- | Now we actually execute the plan. + rebuildTargets, + -- ** Build outcomes + -- | This is the outcome for each package of executing the plan. + -- For each package, did the build succeed or fail? + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.PackageHash (renderPackageHashInputs) +import Distribution.Client.RebuildMonad +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.Store + +import Distribution.Client.Types + hiding (BuildOutcomes, BuildOutcome, + BuildResult(..), BuildFailure(..)) +import Distribution.Client.InstallPlan + ( GenericInstallPlan, GenericPlanPackage, IsUnit ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.DistDirLayout +import Distribution.Client.FileMonitor +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import Distribution.Client.GlobalFlags (RepoContext) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Setup (filterConfigureFlags) +import Distribution.Client.SourceFiles +import Distribution.Client.SrcDist (allPackageSourceFiles) +import Distribution.Client.Utils (removeExistingFile) + +import Distribution.Package hiding (InstalledPackageId, installedPackageId) +import qualified Distribution.PackageDescription as PD +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Types.BuildType +import Distribution.Simple.Program +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Command (CommandUI) +import qualified Distribution.Simple.Register as Cabal +import Distribution.Simple.LocalBuildInfo (ComponentName) +import Distribution.Simple.Compiler + ( Compiler, compilerId, PackageDB(..) ) + +import Distribution.Simple.Utils hiding (matchFileGlob) +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text +import Distribution.ParseUtils ( showPWarning ) +import Distribution.Compat.Graph (IsNode(..)) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as LBS + +import Control.Monad +import Control.Exception +import Data.Maybe + +import System.FilePath +import System.IO +import System.Directory + + +------------------------------------------------------------------------------ +-- * Overall building strategy. +------------------------------------------------------------------------------ +-- +-- We start with an 'ElaboratedInstallPlan' that has already been improved by +-- reusing packages from the store, and pruned to include only the targets of +-- interest and their dependencies. So the remaining packages in the +-- 'InstallPlan.Configured' state are ones we either need to build or rebuild. +-- +-- First, we do a preliminary dry run phase where we work out which packages +-- we really need to (re)build, and for the ones we do need to build which +-- build phase to start at. +-- +-- We use this to improve the 'ElaboratedInstallPlan' again by changing +-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' +-- so that the build phase will skip them. +-- +-- Then we execute the plan, that is actually build packages. The outcomes of +-- trying to build all the packages are collected and returned. +-- +-- We split things like this (dry run and execute) for a couple reasons. +-- Firstly we need to be able to do dry runs anyway, and these need to be +-- reasonably accurate in terms of letting users know what (and why) things +-- are going to be (re)built. +-- +-- Given that we need to be able to do dry runs, it would not be great if +-- we had to repeat all the same work when we do it for real. Not only is +-- it duplicate work, but it's duplicate code which is likely to get out of +-- sync. So we do things only once. We preserve info we discover in the dry +-- run phase and rely on it later when we build things for real. This also +-- somewhat simplifies the build phase. So this way the dry run can't so +-- easily drift out of sync with the real thing since we're relying on the +-- info it produces. +-- +-- An additional advantage is that it makes it easier to debug rebuild +-- errors (ie rebuilding too much or too little), since all the rebuild +-- decisions are made without making any state changes at the same time +-- (that would make it harder to reproduce the problem situation). +-- +-- Finally, we can use the dry run build status and the build outcomes to +-- give us some information on the overall status of packages in the project. +-- This includes limited information about the status of things that were +-- not actually in the subset of the plan that was used for the dry run or +-- execution phases. In particular we may know that some packages are now +-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for +-- details. + + +------------------------------------------------------------------------------ +-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildStatusMap = ... +-- data BuildStatus = ... +-- data BuildStatusRebuild = ... +-- data BuildReason = ... + +-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. +-- +-- It gives us the 'BuildStatusMap'. This should be used with +-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of +-- the 'ElaboratedInstallPlan' with packages switched to the +-- 'InstallPlan.Installed' state when we find that they're already up to date. +-- +rebuildTargetsDryRun :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO BuildStatusMap +rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = + -- Do the various checks to work out the 'BuildStatus' of each package + foldMInstallPlanDepOrder dryRunPkg + where + dryRunPkg :: ElaboratedPlanPackage + -> [BuildStatus] + -> IO BuildStatus + dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = + return BuildStatusPreExisting + + dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = + return BuildStatusInstalled + + dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do + mloc <- checkFetched (elabPkgSourceLocation pkg) + case mloc of + Nothing -> return BuildStatusDownload + + Just (LocalUnpackedPackage srcdir) -> + -- For the case of a user-managed local dir, irrespective of the + -- build style, we build from that directory and put build + -- artifacts under the shared dist directory. + dryRunLocalPkg pkg depsBuildStatus srcdir + + -- The three tarball cases are handled the same as each other, + -- though depending on the build style. + Just (LocalTarballPackage tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RemoteTarballPackage _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + Just (RepoTarballPackage _ _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + dryRunTarballPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunTarballPkg pkg depsBuildStatus tarball = + case elabBuildStyle pkg of + BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildInplaceOnly -> do + -- TODO: [nice to have] use a proper file monitor rather than this dir exists test + exists <- doesDirectoryExist srcdir + if exists + then dryRunLocalPkg pkg depsBuildStatus srcdir + else return (BuildStatusUnpack tarball) + where + srcdir = distUnpackedSrcDirectory (packageId pkg) + + dryRunLocalPkg :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunLocalPkg pkg depsBuildStatus srcdir = do + -- Go and do lots of I/O, reading caches and probing files to work out + -- if anything has changed + change <- checkPackageFileMonitorChanged + packageFileMonitor pkg srcdir depsBuildStatus + case change of + -- It did change, giving us 'BuildStatusRebuild' info on why + Left rebuild -> + return (BuildStatusRebuild srcdir rebuild) + + -- No changes, the package is up to date. Use the saved build results. + Right buildResult -> + return (BuildStatusUpToDate buildResult) + where + packageFileMonitor = + newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg) + + +-- | A specialised traversal over the packages in an install plan. +-- +-- The packages are visited in dependency order, starting with packages with no +-- dependencies. The result for each package is accumulated into a 'Map' and +-- returned as the final result. In addition, when visting a package, the +-- visiting function is passed the results for all the immediate package +-- dependencies. This can be used to propagate information from dependencies. +-- +foldMInstallPlanDepOrder + :: forall m ipkg srcpkg b. + (Monad m, IsUnit ipkg, IsUnit srcpkg) + => (GenericPlanPackage ipkg srcpkg -> + [b] -> m b) + -> GenericInstallPlan ipkg srcpkg + -> m (Map UnitId b) +foldMInstallPlanDepOrder visit = + go Map.empty . InstallPlan.reverseTopologicalOrder + where + go :: Map UnitId b + -> [GenericPlanPackage ipkg srcpkg] + -> m (Map UnitId b) + go !results [] = return results + + go !results (pkg : pkgs) = do + -- we go in the right order so the results map has entries for all deps + let depresults :: [b] + depresults = + map (\ipkgid -> let Just result = Map.lookup ipkgid results + in result) + (InstallPlan.depends pkg) + result <- visit pkg depresults + let results' = Map.insert (nodeKey pkg) result results + go results' pkgs + +improveInstallPlanWithUpToDatePackages :: BuildStatusMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithUpToDatePackages pkgsBuildStatus = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved pkg = + case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + Just BuildStatusUpToDate {} -> True + Just _ -> False + Nothing -> error $ "improveInstallPlanWithUpToDatePackages: " + ++ display (packageId pkg) ++ " not in status map" + + +----------------------------- +-- Package change detection +-- + +-- | As part of the dry run for local unpacked packages we have to check if the +-- package config or files have changed. That is the purpose of +-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. +-- +-- When a package is (re)built, the monitor must be updated to reflect the new +-- state of the package. Because we sometimes build without reconfiguring the +-- state updates are split into two, one for package config changes and one +-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' +-- and 'updatePackageBuildFileMonitor'. +-- +data PackageFileMonitor = PackageFileMonitor { + pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), + pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, + pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) + } + +-- | This is all the components of the 'BuildResult' other than the +-- @['InstalledPackageInfo']@. +-- +-- We have to split up the 'BuildResult' components since they get produced +-- at different times (or rather, when different things change). +-- +type BuildResultMisc = (DocsResult, TestsResult) + +newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor +newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams = + PackageFileMonitor { + pkgFileMonitorConfig = + newFileMonitor (distPackageCacheFile dparams "config"), + + pkgFileMonitorBuild = + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "build", + fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> + componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, + fileMonitorCheckIfOnlyValueChanged = True + }, + + pkgFileMonitorReg = + newFileMonitor (distPackageCacheFile dparams "registration") + } + +-- | Helper function for 'checkPackageFileMonitorChanged', +-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. +-- +-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by +-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. +-- +packageFileMonitorKeyValues :: ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, Set ComponentName) +packageFileMonitorKeyValues elab = + (elab_config, buildComponents) + where + -- The first part is the value used to guard (re)configuring the package. + -- That is, if this value changes then we will reconfigure. + -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of + -- information that affects the (re)configure step. But those parts that + -- do not affect the configure step need to be nulled out. Those parts are + -- the specific targets that we're going to build. + -- + elab_config = + elab { + elabBuildTargets = [], + elabTestTargets = [], + elabReplTarget = Nothing, + elabBuildHaddocks = False + } + + -- The second part is the value used to guard the build step. So this is + -- more or less the opposite of the first part, as it's just the info about + -- what targets we're going to build. + -- + buildComponents = elabBuildTargetWholeComponents elab + +-- | Do all the checks on whether a package has changed and thus needs either +-- rebuilding or reconfiguring and rebuilding. +-- +checkPackageFileMonitorChanged :: PackageFileMonitor + -> ElaboratedConfiguredPackage + -> FilePath + -> [BuildStatus] + -> IO (Either BuildStatusRebuild BuildResult) +checkPackageFileMonitorChanged PackageFileMonitor{..} + pkg srcdir depsBuildStatus = do + --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged + configChanged <- checkFileMonitorChanged + pkgFileMonitorConfig srcdir pkgconfig + case configChanged of + MonitorChanged monitorReason -> + return (Left (BuildStatusConfigure monitorReason')) + where + monitorReason' = fmap (const ()) monitorReason + + MonitorUnchanged () _ + -- The configChanged here includes the identity of the dependencies, + -- so depsBuildStatus is just needed for the changes in the content + -- of dependencies. + | any buildStatusRequiresBuild depsBuildStatus -> do + regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) + + | otherwise -> do + buildChanged <- checkFileMonitorChanged + pkgFileMonitorBuild srcdir buildComponents + regChanged <- checkFileMonitorChanged + pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + case (buildChanged, regChanged) of + (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonExtraTargets prevBuildComponents + + (MonitorChanged monitorReason, _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorChanged monitorReason) -> + -- this should only happen if the file is corrupt or been + -- manually deleted. We don't want to bother with another + -- phase just for this, so we'll reregister by doing a build. + return (Left (BuildStatusBuild Nothing buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + + (MonitorUnchanged _ _, MonitorUnchanged _ _) + | pkgHasEphemeralBuildTargets pkg -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonEphemeralTargets + + (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> + return $ Right BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + where + (docsResult, testsResult) = buildResult + where + (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + changedToMaybe (MonitorChanged _) = Nothing + changedToMaybe (MonitorUnchanged x _) = Just x + + +updatePackageConfigFileMonitor :: PackageFileMonitor + -> FilePath + -> ElaboratedConfiguredPackage + -> IO () +updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig} + srcdir pkg = + updateFileMonitor pkgFileMonitorConfig srcdir Nothing + [] pkgconfig () + where + (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg + +updatePackageBuildFileMonitor :: PackageFileMonitor + -> FilePath + -> MonitorTimestamp + -> ElaboratedConfiguredPackage + -> BuildStatusRebuild + -> [MonitorFilePath] + -> BuildResultMisc + -> IO () +updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} + srcdir timestamp pkg pkgBuildStatus + monitors buildResult = + updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) + monitors buildComponents' buildResult + where + (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + + -- If the only thing that's changed is that we're now building extra + -- components, then we can avoid later unnecessary rebuilds by saving the + -- total set of components that have been built, namely the union of the + -- existing ones plus the new ones. If files also changed this would be + -- the wrong thing to do. Note that we rely on the + -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee + -- that it's /only/ the value that changed not any files that changed. + buildComponents' = + case pkgBuildStatus of + BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) + -> buildComponents `Set.union` prevBuildComponents + _ -> buildComponents + +updatePackageRegFileMonitor :: PackageFileMonitor + -> FilePath + -> Maybe InstalledPackageInfo + -> IO () +updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} + srcdir mipkg = + updateFileMonitor pkgFileMonitorReg srcdir Nothing + [] () mipkg + +invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () +invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = + removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) + + +------------------------------------------------------------------------------ +-- * Doing it: executing an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildOutcomes = ... +-- type BuildOutcome = ... +-- data BuildResult = ... +-- data BuildFailure = ... +-- data BuildFailureReason = ... + +-- | Build things for real. +-- +-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. +-- +rebuildTargets :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> IO BuildOutcomes +rebuildTargets verbosity + distDirLayout@DistDirLayout{..} + storeDirLayout + installPlan + sharedPackageConfig@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + pkgsBuildStatus + buildSettings@BuildTimeSettings{ + buildSettingNumJobs, + buildSettingKeepGoing + } = do + + -- Concurrency control: create the job controller and concurrency limits + -- for downloading, building and installing. + jobControl <- if isParallelBuild + then newParallelJobControl buildSettingNumJobs + else newSerialJobControl + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + --TODO: [code cleanup] eliminate setup exe cache + + debug verbosity $ + "Executing install plan " + ++ if isParallelBuild + then " in parallel using " ++ show buildSettingNumJobs ++ " threads." + else " serially." + + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory + mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + + -- Before traversing the install plan, pre-emptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages verbosity withRepoCtx + installPlan pkgsBuildStatus $ \downloadMap -> + + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute jobControl keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan $ \pkg -> + --TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ + + let uid = installedUnitId pkg + Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + installPlan pkg + pkgBuildStatus + where + isParallelBuild = buildSettingNumJobs >= 2 + keepGoing = buildSettingKeepGoing + withRepoCtx = projectConfigWithBuilderRepoContext verbosity + buildSettings + packageDBsToUse = -- all the package dbs we may need to create + (Set.toList . Set.fromList) + [ pkgdb + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , pkgdb <- concat [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab ] + ] + + +-- | Create a package DB if it does not currently exist. Note that this action +-- is /not/ safe to run concurrently. +-- +createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb + -> PackageDB -> IO () +createPackageDBIfMissing verbosity compiler progdb + (SpecificPackageDB dbPath) = do + exists <- Cabal.doesPackageDBExist dbPath + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity compiler progdb False dbPath +createPackageDBIfMissing _ _ _ _ = return () + + +-- | Given all the context and resources, (re)build an individual package. +-- +rebuildTarget :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings + -> AsyncFetchMap + -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatus + -> IO BuildResult +rebuildTarget verbosity + distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout + buildSettings downloadMap + registerLock cacheLock + sharedPackageConfig + plan rpkg@(ReadyPackage pkg) + pkgBuildStatus = + + -- We rely on the 'BuildStatus' to decide which phase to start from: + case pkgBuildStatus of + BuildStatusDownload -> downloadPhase + BuildStatusUnpack tarball -> unpackTarballPhase tarball + BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + + -- TODO: perhaps re-nest the types to make these impossible + BuildStatusPreExisting {} -> unexpectedState + BuildStatusInstalled {} -> unexpectedState + BuildStatusUpToDate {} -> unexpectedState + where + unexpectedState = error "rebuildTarget: unexpected package status" + + downloadPhase = do + downsrcloc <- annotateFailureNoLog DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg + case downsrcloc of + DownloadedTarball tarball -> unpackTarballPhase tarball + --TODO: [nice to have] git/darcs repos etc + + + unpackTarballPhase tarball = + withTarballLocalDirectory + verbosity distDirLayout tarball + (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) + (elabPkgDescriptionOverride pkg) $ + + case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall + BuildInplaceOnly -> buildInplace buildStatus + where + buildStatus = BuildStatusConfigure MonitorFirstRun + + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase buildStatus srcdir = + assert (elabBuildStyle pkg == BuildInplaceOnly) $ + + buildInplace buildStatus srcdir builddir + where + builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) + + buildAndInstall srcdir builddir = + buildAndInstallUnpackedPackage + verbosity distDirLayout storeDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + rpkg + srcdir builddir' + where + builddir' = makeRelative srcdir builddir + --TODO: [nice to have] ^^ do this relative stuff better + + buildInplace buildStatus srcdir builddir = + --TODO: [nice to have] use a relative build dir rather than absolute + buildInplaceUnpackedPackage + verbosity distDirLayout + buildSettings registerLock cacheLock + sharedPackageConfig + plan rpkg + buildStatus + srcdir builddir + +--TODO: [nice to have] do we need to use a with-style for the temp files for downloading http +-- packages, or are we going to cache them persistently? + +-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the +-- packages we have to download and fork off an async action to download them. +-- We download them in dependency order so that the one's we'll need +-- first are the ones we will start downloading first. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'waitAsyncPackageDownload' to get the result. +-- +asyncDownloadPackages :: Verbosity + -> ((RepoContext -> IO a) -> IO a) + -> ElaboratedInstallPlan + -> BuildStatusMap + -> (AsyncFetchMap -> IO a) + -> IO a +asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body + | null pkgsToDownload = body Map.empty + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages verbosity repoctx + pkgsToDownload body + where + pkgsToDownload = + ordNub $ + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab + <- InstallPlan.reverseTopologicalOrder installPlan + , let uid = installedUnitId elab + Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus + , BuildStatusDownload <- [pkgBuildStatus] + ] + + +-- | Check if a package needs downloading, and if so expect to find a download +-- in progress in the given 'AsyncFetchMap' and wait on it to finish. +-- +waitAsyncPackageDownload :: Verbosity + -> AsyncFetchMap + -> ElaboratedConfiguredPackage + -> IO DownloadedSourceLocation +waitAsyncPackageDownload verbosity downloadMap elab = do + pkgloc <- waitAsyncFetchPackage verbosity downloadMap + (elabPkgSourceLocation elab) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + +data DownloadedSourceLocation = DownloadedTarball FilePath + --TODO: [nice to have] git/darcs repos etc + +downloadedSourceLocation :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing + + + + +-- | Ensure that the package is unpacked in an appropriate directory, either +-- a temporary one or a persistent one under the shared dist directory. +-- +withTarballLocalDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> BuildStyle + -> Maybe CabalFileText + -> (FilePath -> -- Source directory + FilePath -> -- Build directory + IO a) + -> IO a +withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} + tarball pkgid dparams buildstyle pkgTextOverride + buildPkg = + case buildstyle of + -- In this case we make a temp dir (e.g. tmp/src2345/), unpack + -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for + -- compatibility we put the dist dir within it + -- (i.e. tmp/src2345/foo-1.0/dist/). + -- + -- Unfortunately, a few custom Setup.hs scripts do not respect + -- the --builddir flag and always look for it at ./dist/ so + -- this way we avoid breaking those packages + BuildAndInstall -> + let tmpdir = distTempDirectory in + withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + unpackPackageTarball verbosity tarball unpackdir + pkgid pkgTextOverride + let srcdir = unpackdir display pkgid + builddir = srcdir "dist" + buildPkg srcdir builddir + + -- In this case we make sure the tarball has been unpacked to the + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- TODO: [nice to have] use a proper file monitor rather than this dir exists test + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball verbosity tarball srcrootdir + pkgid pkgTextOverride + moveTarballShippedDistDirectory verbosity distDirLayout + srcrootdir pkgid dparams + buildPkg srcdir builddir + + +unpackPackageTarball :: Verbosity -> FilePath -> FilePath + -> PackageId -> Maybe CabalFileText + -> IO () +unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = + --TODO: [nice to have] switch to tar package and catch tar exceptions + annotateFailureNoLog UnpackFailed $ do + + -- Unpack the tarball + -- + info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." + Tar.extractTarGzFile parentdir pkgsubdir tarball + + -- Sanity check + -- + exists <- doesFileExist cabalFile + when (not exists) $ + die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile + + -- Overwrite the .cabal with the one from the index, when appropriate + -- + case pkgTextOverride of + Nothing -> return () + Just pkgtxt -> do + info verbosity $ "Updating " ++ display pkgname <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic cabalFile pkgtxt + + where + cabalFile = parentdir pkgsubdir + display pkgname <.> "cabal" + pkgsubdir = display pkgid + pkgname = packageName pkgid + + +-- | This is a bit of a hacky workaround. A number of packages ship +-- pre-processed .hs files in a dist directory inside the tarball. We don't +-- use the standard 'dist' location so unless we move this dist dir to the +-- right place then we'll miss the shipped pre-procssed files. This hacky +-- approach to shipped pre-procssed files ought to be replaced by a proper +-- system, though we'll still need to keep this hack for older packages. +-- +moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout + -> FilePath -> PackageId -> DistDirParams -> IO () +moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} + parentdir pkgid dparams = do + distDirExists <- doesDirectoryExist tarballDistDir + when distDirExists $ do + debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" + ++ targetDistDir ++ "'" + --TODO: [nice to have] or perhaps better to copy, and use a file monitor + renameDirectory tarballDistDir targetDistDir + where + tarballDistDir = parentdir display pkgid "dist" + targetDistDir = distBuildDirectory dparams + + +buildAndInstallUnpackedPackage :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedReadyPackage + -> FilePath -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage verbosity + DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout { + storePackageDBStack + } + BuildTimeSettings { + buildSettingNumJobs, + buildSettingLogFile + } + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + rpkg@(ReadyPackage pkg) + srcdir builddir = do + + createDirectoryIfMissingVerbose verbosity True builddir + initLogFile + + --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like + -- we do for ghc, with a proper options type and rendering step + -- which will also let us call directly into the lib, rather than always + -- going via the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and program db for a + -- quicker configure. + + --TODO: [required feature] docs and tests + --TODO: [required feature] sudo re-exec + + let dispname = case elabPkgOrComp pkg of + ElabPackage _ -> display pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> display pkgid + ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")" + + -- Configure phase + when isParallelBuild $ + notice verbosity $ "Configuring " ++ dispname ++ "..." + annotateFailure mlogFile ConfigureFailed $ + setup' configureCommand configureFlags configureArgs + + -- Build phase + when isParallelBuild $ + notice verbosity $ "Building " ++ dispname ++ "..." + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags + + -- Install phase + annotateFailure mlogFile InstallFailed $ do + + let copyPkgFiles tmpDir = do + setup Cabal.copyCommand (copyFlags tmpDir) + -- Note that the copy command has put the files into + -- @$tmpDir/$prefix@ so we need to return this dir so + -- the store knows which dir will be the final store entry. + let prefix = dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDir prefix + LBS.writeFile + (entryDir "cabal-hash.txt") + (renderPackageHashInputs (packageHashInputs pkgshared pkg)) + -- here's where we could keep track of the installed files ourselves + -- if we wanted to by making a manifest of the files in the tmp dir + return entryDir + + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " ++ display uid + | otherwise = do + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + ipkg0 <- generateInstalledPackageInfo + let ipkg = ipkg0 { Installed.installedUnitId = uid } + assert ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid) (return ()) + criticalSection registerLock $ + Cabal.registerPackage + verbosity compiler progdb + (storePackageDBStack compid) ipkg + Cabal.defaultRegisterOptions { + Cabal.registerMultiInstance = True, + Cabal.registerSuppressFilesCheck = True + } + + + -- Actual installation + void $ newStoreEntry verbosity storeDirLayout + compid uid + copyPkgFiles registerPkg + + --TODO: [nice to have] we currently rely on Setup.hs copy to do the right + -- thing. Although we do copy into an image dir and do the move into the + -- final location ourselves, perhaps we ought to do some sanity checks on + -- the image dir first. + + -- TODO: [required eventually] note that for nix-style installations it is not necessary to do + -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a + -- shared bin dir. + + --TODO: [required feature] docs and test phases + let docsResult = DocsNotTried + testsResult = TestsNotTried + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = mlogFile + } + + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + isParallelBuild = buildSettingNumJobs >= 2 + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity + builddir destdir + + scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir + isParallelBuild cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags [] + + setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions { useLoggingHandle = mLogFileHandle } + (Just (elabPkgDescription pkg)) + cmd flags args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + + +buildInplaceUnpackedPackage :: Verbosity + -> DistDirLayout + -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage verbosity + distDirLayout@DistDirLayout { + distTempDirectory, + distPackageCacheDirectory + } + BuildTimeSettings{buildSettingNumJobs} + registerLock cacheLock + pkgshared@ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = progdb + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir builddir = do + + --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here + -- builddir is not enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity scriptOptions srcdir + ifNullThen m m' = do xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Just Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + -> listSdist `ifNullThen` listSimple + | otherwise + -> listSimple + + let dep_monitors = map monitorFileHashed + $ elabInplaceDependencyBuildCacheFiles + distDirLayout pkgshared plan pkg + updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp + pkg buildStatus + (monitors ++ dep_monitors) buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } + criticalSection registerLock $ + Cabal.registerPackage verbosity compiler progdb + (elabRegisterPackageDBStack pkg) + ipkg Cabal.defaultRegisterOptions + return (Just ipkg) + + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs + + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags [] + + return BuildResult { + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing + } + + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg + + isParallelBuild = buildSettingNumJobs >= 2 + + packageFileMonitor = newPackageFileMonitor distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + -- NB: we have to build the test suite! + , null (elabTestTargets pkg) = return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenRepl action + | isNothing (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | elabBuildHaddocks pkg = action + | otherwise = return () + + whenReRegister action + = case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ | null (elabBuildTargets pkg) -> info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = flip filterConfigureFlags v $ + setupHsConfigureFlags rpkg pkgshared + verbosity builddir + configureArgs = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags pkg pkgshared + verbosity builddir + buildArgs = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags _ = setupHsTestFlags pkg pkgshared + verbosity builddir + testArgs = setupHsTestArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = setupHsReplFlags pkg pkgshared + verbosity builddir + replArgs = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = setupHsHaddockFlags pkg pkgshared + verbosity builddir + + scriptOptions = setupHsScriptOptions rpkg pkgshared + srcdir builddir + isParallelBuild cacheLock + + setupInteractive :: CommandUI flags + -> (Version -> flags) -> [String] -> IO () + setupInteractive cmd flags args = + setupWrapper verbosity + scriptOptions { isInteractive = True } + (Just (elabPkgDescription pkg)) + cmd flags args + + setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO () + setup cmd flags args = + setupWrapper verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd flags args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity distTempDirectory $ \pkgConfDest -> do + let registerFlags _ = setupHsRegisterFlags + pkg pkgshared + verbosity builddir + pkgConfDest + setup Cabal.registerCommand registerFlags [] + +withTempInstalledPackageInfoFile :: Verbosity -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: Installed.PError -> IO a + pkgConfParseFailed perror = + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + ++ show perror + + readPkgConf pkgConfDir pkgConfFile = do + (warns, ipkg) <- withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfStr -> + case Installed.parseInstalledPackageInfo pkgConfStr of + Installed.ParseFailed perror -> pkgConfParseFailed perror + Installed.ParseOk warns ipkg -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ unlines (map (showPWarning pkgConfFile) warns) + + return ipkg + + +------------------------------------------------------------------------------ +-- * Utilities +------------------------------------------------------------------------------ + +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/Distribution/Client/ProjectBuilding/Types.hs b/Distribution/Client/ProjectBuilding/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/ProjectBuilding/Types.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Types for the "Distribution.Client.ProjectBuilding" +-- +-- Moved out to avoid module cycles. +-- +module Distribution.Client.ProjectBuilding.Types ( + -- * Pre-build status + BuildStatusMap, + BuildStatus(..), + buildStatusRequiresBuild, + buildStatusToString, + BuildStatusRebuild(..), + BuildReason(..), + MonitorChangedReason(..), + + -- * Build outcomes + BuildOutcomes, + BuildOutcome, + BuildResult(..), + BuildFailure(..), + BuildFailureReason(..), + ) where + +import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.FileMonitor (MonitorChangedReason(..)) + +import Distribution.Package (UnitId, PackageId) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.LocalBuildInfo (ComponentName) + +import Data.Map (Map) +import Data.Set (Set) +import Data.Typeable (Typeable) +import Control.Exception (Exception, SomeException) + + +------------------------------------------------------------------------------ +-- Pre-build status: result of the dry run +-- + +-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. +-- +-- This is used as the result of the dry-run of building an install plan. +-- +type BuildStatusMap = Map UnitId BuildStatus + +-- | The build status for an individual package is the state that the +-- package is in /prior/ to initiating a (re)build. +-- +-- This should not be confused with a 'BuildResult' which is the result +-- /after/ successfully building a package. +-- +-- It serves two purposes: +-- +-- * For dry-run output, it lets us explain to the user if and why a package +-- is going to be (re)built. +-- +-- * It tell us what step to start or resume building from, and carries +-- enough information for us to be able to do so. +-- +data BuildStatus = + + -- | The package is in the 'InstallPlan.PreExisting' state, so does not + -- need building. + BuildStatusPreExisting + + -- | The package is in the 'InstallPlan.Installed' state, so does not + -- need building. + | BuildStatusInstalled + + -- | The package has not been downloaded yet, so it will have to be + -- downloaded, unpacked and built. + | BuildStatusDownload + + -- | The package has not been unpacked yet, so it will have to be + -- unpacked and built. + | BuildStatusUnpack FilePath + + -- | The package exists in a local dir already, and just needs building + -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style + -- packages. + | BuildStatusRebuild FilePath BuildStatusRebuild + + -- | The package exists in a local dir already, and is fully up to date. + -- So this package can be put into the 'InstallPlan.Installed' state + -- and it does not need to be built. + | BuildStatusUpToDate BuildResult + + +-- | Which 'BuildStatus' values indicate we'll have to do some build work of +-- some sort. In particular we use this as part of checking if any of a +-- package's deps have changed. +-- +buildStatusRequiresBuild :: BuildStatus -> Bool +buildStatusRequiresBuild BuildStatusPreExisting = False +buildStatusRequiresBuild BuildStatusInstalled = False +buildStatusRequiresBuild BuildStatusUpToDate {} = False +buildStatusRequiresBuild _ = True + +-- | This is primarily here for debugging. It's not actually used anywhere. +-- +buildStatusToString :: BuildStatus -> String +buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" +buildStatusToString BuildStatusInstalled = "BuildStatusInstalled" +buildStatusToString BuildStatusDownload = "BuildStatusDownload" +buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp +buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp +buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" + + +-- | For a package that is going to be built or rebuilt, the state it's in now. +-- +-- So again, this tells us why a package needs to be rebuilt and what build +-- phases need to be run. The 'MonitorChangedReason' gives us details like +-- which file changed, which is mainly for high verbosity debug output. +-- +data BuildStatusRebuild = + + -- | The package configuration changed, so the configure and build phases + -- needs to be (re)run. + BuildStatusConfigure (MonitorChangedReason ()) + + -- | The configuration has not changed but the build phase needs to be + -- rerun. We record the reason the (re)build is needed. + -- + -- The optional registration info here tells us if we've registered the + -- package already, or if we still need to do that after building. + -- @Just Nothing@ indicates that we know that no registration is + -- necessary (e.g., executable.) + -- + | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + +data BuildReason = + -- | The dependencies of this package have been (re)built so the build + -- phase needs to be rerun. + -- + BuildReasonDepsRebuilt + + -- | Changes in files within the package (or first run or corrupt cache) + | BuildReasonFilesChanged (MonitorChangedReason ()) + + -- | An important special case is that no files have changed but the + -- set of components the /user asked to build/ has changed. We track the + -- set of components /we have built/, which of course only grows (until + -- some other change resets it). + -- + -- The @Set 'ComponentName'@ is the set of components we have built + -- previously. When we update the monitor we take the union of the ones + -- we have built previously with the ones the user has asked for this + -- time and save those. See 'updatePackageBuildFileMonitor'. + -- + | BuildReasonExtraTargets (Set ComponentName) + + -- | Although we're not going to build any additional targets as a whole, + -- we're going to build some part of a component or run a repl or any + -- other action that does not result in additional persistent artifacts. + -- + | BuildReasonEphemeralTargets + + +------------------------------------------------------------------------------ +-- Build outcomes: result of the build +-- + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + +-- | A summary of the outcome for building a single package: either success +-- or failure. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | Information arising from successfully building a single package. +-- +data BuildResult = BuildResult { + buildResultDocs :: DocsResult, + buildResultTests :: TestsResult, + buildResultLogFile :: Maybe FilePath + } + deriving Show + +-- | Information arising from the failure to build a single package. +-- +data BuildFailure = BuildFailure { + buildFailureLogFile :: Maybe FilePath, + buildFailureReason :: BuildFailureReason + } + deriving (Show, Typeable) + +instance Exception BuildFailure + +-- | Detail on the reason that a package failed to build. +-- +data BuildFailureReason = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | ReplFailed SomeException + | HaddocksFailed SomeException + | TestsFailed SomeException + | InstallFailed SomeException + deriving Show + diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -8,14 +8,21 @@ ProjectConfig(..), ProjectConfigBuildOnly(..), ProjectConfigShared(..), + ProjectConfigProvenance(..), PackageConfig(..), MapLast(..), MapMappend(..), - -- * Project config files + -- * Project root findProjectRoot, + ProjectRoot(..), + BadProjectRoot(..), + + -- * Project config files readProjectConfig, + readProjectLocalFreezeConfig, writeProjectLocalExtraConfig, + writeProjectLocalFreezeConfig, writeProjectConfigFile, commandLineFlagsToProjectConfig, @@ -41,6 +48,9 @@ BadPerPackageCompilerPaths(..) ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectConfig.Legacy import Distribution.Client.RebuildMonad @@ -49,36 +59,47 @@ import Distribution.Client.Types import Distribution.Client.DistDirLayout - ( CabalDirLayout(..) ) + ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) import Distribution.Client.GlobalFlags ( RepoContext(..), withRepoContext' ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Config ( loadConfig, defaultConfigFile ) +import Distribution.Client.IndexUtils.Timestamp + ( IndexState(..) ) +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings + import Distribution.Package - ( PackageName, PackageId, packageId, UnitId, Dependency ) + ( PackageName, PackageId, packageId, UnitId ) +import Distribution.Types.Dependency import Distribution.System ( Platform ) import Distribution.PackageDescription ( SourceRepo(..) ) +#if CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +#else import Distribution.PackageDescription.Parse - ( readPackageDescription ) + ( readGenericPackageDescription ) +#endif import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program ( ConfiguredProgram(..) ) import Distribution.Simple.Setup ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, AllowNewer(..) ) + , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps, ) + ( defaultSolver, defaultMaxBackjumps ) import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils - ( die, warn ) + ( die', warn ) import Distribution.Client.Utils ( determineNumJobs ) import Distribution.Utils.NubList @@ -89,19 +110,14 @@ import Distribution.ParseUtils ( ParseResult(..), locatedErrorMsg, showPWarning ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception -import Data.Typeable import Data.Maybe import Data.Either import qualified Data.Map as Map -import Data.Map (Map) +import Data.Set (Set) import qualified Data.Set as Set -import Distribution.Compat.Semigroup import System.FilePath hiding (combine) import System.Directory import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI) @@ -149,18 +165,18 @@ -- to the 'BuildTimeSettings' -- projectConfigWithSolverRepoContext :: Verbosity - -> FilePath -> ProjectConfigShared -> ProjectConfigBuildOnly -> (RepoContext -> IO a) -> IO a -projectConfigWithSolverRepoContext verbosity downloadCacheRootDir +projectConfigWithSolverRepoContext verbosity ProjectConfigShared{..} ProjectConfigBuildOnly{..} = withRepoContext' verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalRepos) - downloadCacheRootDir + (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir") + projectConfigCacheDir) (flagToMaybe projectConfigHttpTransport) (flagToMaybe projectConfigIgnoreExpiry) @@ -187,12 +203,16 @@ (getMapMappend projectConfigSpecificPackage) solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion solverSettingSolver = fromFlag projectConfigSolver + solverSettingAllowOlder = fromJust projectConfigAllowOlder solverSettingAllowNewer = fromJust projectConfigAllowNewer solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of n | n < 0 -> Nothing | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals + solverSettingCountConflicts = fromFlag projectConfigCountConflicts solverSettingStrongFlags = fromFlag projectConfigStrongFlags + solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingIndexState = fromFlagOrDefault IndexStateHead projectConfigIndexState --solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs --solverSettingReinstall = fromFlag projectConfigReinstall @@ -204,11 +224,14 @@ defaults = mempty { projectConfigSolver = Flag defaultSolver, - projectConfigAllowNewer = Just AllowNewerNone, + projectConfigAllowOlder = Just (AllowOlder RelaxDepsNone), + projectConfigAllowNewer = Just (AllowNewer RelaxDepsNone), projectConfigMaxBackjumps = Flag defaultMaxBackjumps, - projectConfigReorderGoals = Flag False, - projectConfigStrongFlags = Flag False - --projectConfigIndependentGoals = Flag False, + projectConfigReorderGoals = Flag (ReorderGoals False), + projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigStrongFlags = Flag (StrongFlags False), + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False) + --projectConfigIndependentGoals = Flag (IndependentGoals False), --projectConfigShadowPkgs = Flag False, --projectConfigReinstall = Flag False, --projectConfigAvoidReinstalls = Flag False, @@ -222,52 +245,50 @@ -- resolveBuildTimeSettings :: Verbosity -> CabalDirLayout - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> ProjectConfigBuildOnly + -> ProjectConfig -> BuildTimeSettings resolveBuildTimeSettings verbosity CabalDirLayout { - cabalLogsDirectory, - cabalPackageCacheDirectory - } - ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalRepos + cabalLogsDirectory } - fromProjectFile - fromCommandLine = + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigRemoteRepos, + projectConfigLocalRepos + }, + projectConfigBuildOnly + } = BuildTimeSettings {..} where buildSettingDryRun = fromFlag projectConfigDryRun buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps buildSettingSummaryFile = fromNubList projectConfigSummaryFile - --buildSettingLogFile -- defined below, more complicated + --buildSettingLogFile -- defined below, more complicated --buildSettingLogVerbosity -- defined below, more complicated buildSettingBuildReports = fromFlag projectConfigBuildReports buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir buildSettingOneShot = fromFlag projectConfigOneShot buildSettingNumJobs = determineNumJobs projectConfigNumJobs + buildSettingKeepGoing = fromFlag projectConfigKeepGoing buildSettingOfflineMode = fromFlag projectConfigOfflineMode buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos buildSettingLocalRepos = fromNubList projectConfigLocalRepos - buildSettingCacheDir = cabalPackageCacheDirectory + buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry buildSettingReportPlanningFailure = fromFlag projectConfigReportPlanningFailure - buildSettingRootCmd = flagToMaybe projectConfigRootCmd ProjectConfigBuildOnly{..} = defaults - <> fromProjectFile - <> fromCommandLine + <> projectConfigBuildOnly defaults = mempty { projectConfigDryRun = toFlag False, projectConfigOnlyDeps = toFlag False, projectConfigBuildReports = toFlag NoReports, projectConfigReportPlanningFailure = toFlag False, + projectConfigKeepGoing = toFlag False, projectConfigOneShot = toFlag False, projectConfigOfflineMode = toFlag False, projectConfigKeepTempFiles = toFlag False, @@ -288,7 +309,8 @@ | otherwise = fmap substLogFileName givenTemplate defaultTemplate = toPathTemplate $ - cabalLogsDirectory "$pkgid" <.> "log" + cabalLogsDirectory + "$compiler" "$libname" <.> "log" givenTemplate = flagToMaybe projectConfigLogFile useDefaultTemplate @@ -332,58 +354,104 @@ -- parent directories. If no project file is found then the current dir is the -- project root (and the project will use an implicit config). -- -findProjectRoot :: IO FilePath -findProjectRoot = do +findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory + -> Maybe FilePath -- ^ @cabal.project@ file name override + -> IO (Either BadProjectRoot ProjectRoot) +findProjectRoot _ (Just projectFile) + | isAbsolute projectFile = do + exists <- doesFileExist projectFile + if exists + then do projectFile' <- canonicalizePath projectFile + let projectRoot = ProjectRootExplicit (takeDirectory projectFile') + (takeFileName projectFile') + return (Right projectRoot) + else return (Left (BadProjectRootExplicitFile projectFile)) - curdir <- getCurrentDirectory - homedir <- getHomeDirectory +findProjectRoot mstartdir mprojectFile = do + startdir <- maybe getCurrentDirectory canonicalizePath mstartdir + homedir <- getHomeDirectory + probe startdir homedir + where + projectFileName = fromMaybe "cabal.project" mprojectFile -- Search upwards. If we get to the users home dir or the filesystem root, -- then use the current dir - let probe dir | isDrive dir || dir == homedir - = return curdir -- implicit project root - probe dir = do - exists <- doesFileExist (dir "cabal.project") + probe startdir homedir = go startdir + where + go dir | isDrive dir || dir == homedir = + case mprojectFile of + Nothing -> return (Right (ProjectRootImplicit startdir)) + Just file -> return (Left (BadProjectRootExplicitFile file)) + go dir = do + exists <- doesFileExist (dir projectFileName) if exists - then return dir -- explicit project root - else probe (takeDirectory dir) + then return (Right (ProjectRootExplicit dir projectFileName)) + else go (takeDirectory dir) - probe curdir --TODO: [nice to have] add compat support for old style sandboxes +-- | Errors returned by 'findProjectRoot'. +-- +data BadProjectRoot = BadProjectRootExplicitFile FilePath +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadProjectRoot where + show = renderBadProjectRoot +#endif + +instance Exception BadProjectRoot where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadProjectRoot +#endif + +renderBadProjectRoot :: BadProjectRoot -> String +renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = + "The given project file '" ++ projectFile ++ "' does not exist." + + -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. -- -readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectConfig verbosity projectRootDir = do - global <- readGlobalConfig verbosity - local <- readProjectLocalConfig verbosity projectRootDir - extra <- readProjectLocalExtraConfig verbosity projectRootDir - return (global <> local <> extra) +readProjectConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig +readProjectConfig verbosity distDirLayout = do + global <- readGlobalConfig verbosity + local <- readProjectLocalConfig verbosity distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity distDirLayout + extra <- readProjectLocalExtraConfig verbosity distDirLayout + return (global <> local <> freeze <> extra) -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. -- -readProjectLocalConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectLocalConfig verbosity projectRootDir = do +readProjectLocalConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig +readProjectLocalConfig verbosity DistDirLayout{distProjectFile} = do usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile if usesExplicitProjectRoot then do monitorFiles [monitorFileHashed projectFile] - liftIO readProjectFile + addProjectFileProvenance <$> liftIO readProjectFile else do monitorFiles [monitorNonExistentFile projectFile] return defaultImplicitProjectConfig where - projectFile = projectRootDir "cabal.project" + projectFile = distProjectFile "" readProjectFile = reportParseResult verbosity "project file" projectFile . parseProjectConfig =<< readFile projectFile + addProjectFileProvenance config = + config { + projectConfigProvenance = + Set.insert (Explicit projectFile) (projectConfigProvenance config) + } + defaultImplicitProjectConfig :: ProjectConfig defaultImplicitProjectConfig = mempty { @@ -391,30 +459,50 @@ projectPackages = [ "./*.cabal" ], -- This is to automatically pick up deps that we unpack locally. - projectPackagesOptional = [ "./*/*.cabal" ] - } + projectPackagesOptional = [ "./*/*.cabal" ], + projectConfigProvenance = Set.singleton Implicit + } --- | Reads a @cabal.project.extra@ file in the given project root dir, +-- | Reads a @cabal.project.local@ file in the given project root dir, -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. -- -readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectLocalExtraConfig verbosity projectRootDir = do - hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile - if hasExtraConfig - then do monitorFiles [monitorFileHashed projectExtraConfigFile] - liftIO readProjectExtraConfigFile - else do monitorFiles [monitorNonExistentFile projectExtraConfigFile] +readProjectLocalExtraConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalExtraConfig verbosity distDirLayout = + readProjectExtensionFile verbosity distDirLayout "local" + "project local configuration file" + +-- | Reads a @cabal.project.freeze@ file in the given project root dir, +-- or returns empty. This file gets written by @cabal freeze@, or in +-- principle can be edited manually or by other tools. +-- +readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalFreezeConfig verbosity distDirLayout = + readProjectExtensionFile verbosity distDirLayout "freeze" + "project freeze file" + +-- | Reads a named config file in the given project root dir, or returns empty. +-- +readProjectExtensionFile :: Verbosity -> DistDirLayout -> String -> FilePath + -> Rebuild ProjectConfig +readProjectExtensionFile verbosity DistDirLayout{distProjectFile} + extensionName extensionDescription = do + exists <- liftIO $ doesFileExist extensionFile + if exists + then do monitorFiles [monitorFileHashed extensionFile] + liftIO readExtensionFile + else do monitorFiles [monitorNonExistentFile extensionFile] return mempty where - projectExtraConfigFile = projectRootDir "cabal.project.local" + extensionFile = distProjectFile extensionName - readProjectExtraConfigFile = - reportParseResult verbosity "project local configuration file" - projectExtraConfigFile + readExtensionFile = + reportParseResult verbosity extensionDescription extensionFile . parseProjectConfig - =<< readFile projectExtraConfigFile + =<< readFile extensionFile -- | Parse the 'ProjectConfig' format. @@ -438,15 +526,20 @@ showLegacyProjectConfig . convertToLegacyProjectConfig --- | Write a @cabal.project.extra@ file in the given project root dir. +-- | Write a @cabal.project.local@ file in the given project root dir. -- -writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO () -writeProjectLocalExtraConfig projectRootDir = - writeProjectConfigFile projectExtraConfigFile - where - projectExtraConfigFile = projectRootDir "cabal.project.local" +writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "local") +-- | Write a @cabal.project.freeze@ file in the given project root dir. +-- +writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "freeze") + + -- | Write in the @cabal.project@ format to the given file. -- writeProjectConfigFile :: FilePath -> ProjectConfig -> IO () @@ -472,9 +565,9 @@ let msg = unlines (map (showPWarning filename) warnings) in warn verbosity msg return x -reportParseResult _verbosity filetype filename (ParseFailed err) = +reportParseResult verbosity filetype filename (ParseFailed err) = let (line, msg) = locatedErrorMsg err - in die $ "Error parsing " ++ filetype ++ " " ++ filename + in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -498,11 +591,21 @@ -- | Exception thrown by 'findProjectPackages'. -- -newtype BadPackageLocations = BadPackageLocations [BadPackageLocation] +data BadPackageLocations + = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] +#if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) +#else + deriving (Typeable) -instance Exception BadPackageLocations ---TODO: [required eventually] displayException for nice rendering +instance Show BadPackageLocations where + show = renderBadPackageLocations +#endif + +instance Exception BadPackageLocations where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPackageLocations +#endif --TODO: [nice to have] custom exception subclass for Doc rendering, colour etc data BadPackageLocation @@ -521,14 +624,104 @@ | BadLocDirManyCabalFiles String deriving Show +renderBadPackageLocations :: BadPackageLocations -> String +renderBadPackageLocations (BadPackageLocations provenance bpls) + -- There is no provenance information, + -- render standard bad package error information. + | Set.null provenance = renderErrors renderBadPackageLocation --- | Given the project config, + -- The configuration is implicit, render bad package locations + -- using possibly specialized error messages. + | Set.singleton Implicit == provenance = + renderErrors renderImplicitBadPackageLocation + + -- The configuration contains both implicit and explicit provenance. + -- This should not occur, and a message is output to assist debugging. + | Implicit `Set.member` provenance = + "Warning: both implicit and explicit configuration is present." + ++ renderExplicit + + -- The configuration was read from one or more explicit path(s), + -- list the locations and render the bad package error information. + -- The intent is to supersede this with the relevant location information + -- per package error. + | otherwise = renderExplicit + where + renderErrors f = unlines (map f bpls) + + renderExplicit = + "When using configuration(s) from " + ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance)) + ++ ", the following errors occurred:\n" + ++ renderErrors renderBadPackageLocation + + getExplicit (Explicit path) = Just path + getExplicit Implicit = Nothing + +--TODO: [nice to have] keep track of the config file (and src loc) packages +-- were listed, to use in error messages + +-- | Render bad package location error information for the implicit +-- @cabal.project@ configuration. -- +-- TODO: This is currently not fully realized, with only one of the implicit +-- cases handled. More cases should be added with informative help text +-- about the issues related specifically when having no project configuration +-- is present. +renderImplicitBadPackageLocation :: BadPackageLocation -> String +renderImplicitBadPackageLocation bpl = case bpl of + BadLocGlobEmptyMatch pkglocstr -> + "No cabal.project file or cabal file matching the default glob '" + ++ pkglocstr ++ "' was found.\n" + ++ "Please create a package description file .cabal " + ++ "or a cabal.project file referencing the packages you " + ++ "want to build." + _ -> renderBadPackageLocation bpl + +renderBadPackageLocation :: BadPackageLocation -> String +renderBadPackageLocation bpl = case bpl of + BadPackageLocationFile badmatch -> + renderBadPackageLocationMatch badmatch + BadLocGlobEmptyMatch pkglocstr -> + "The package location glob '" ++ pkglocstr + ++ "' does not match any files or directories." + BadLocGlobBadMatches pkglocstr failures -> + "The package location glob '" ++ pkglocstr ++ "' does not match any " + ++ "recognised forms of package. " + ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures + BadLocUnexpectedUriScheme pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not use a " + ++ "supported URI scheme. The supported URI schemes are http, https and " + ++ "file." + BadLocUnrecognisedUri pkglocstr -> + "The package location URI '" ++ pkglocstr ++ "' does not appear to " + ++ "be a valid absolute URI." + BadLocUnrecognised pkglocstr -> + "The package location syntax '" ++ pkglocstr ++ "' is not recognised." + +renderBadPackageLocationMatch :: BadPackageLocationMatch -> String +renderBadPackageLocationMatch bplm = case bplm of + BadLocUnexpectedFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' is not recognised. The " + ++ "supported file targets are .cabal files, .tar.gz tarballs or package " + ++ "directories (i.e. directories containing a .cabal file)." + BadLocNonexistantFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' does not exist." + BadLocDirNoCabalFile pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' does not contain any " + ++ ".cabal file." + BadLocDirManyCabalFiles pkglocstr -> + "The package directory '" ++ pkglocstr ++ "' contains multiple " + ++ ".cabal files (which is not currently supported)." + +-- | Given the project config, +-- -- Throws 'BadPackageLocations'. -- -findProjectPackages :: FilePath -> ProjectConfig +findProjectPackages :: DistDirLayout -> ProjectConfig -> Rebuild [ProjectPackageLocation] -findProjectPackages projectRootDir ProjectConfig{..} = do +findProjectPackages DistDirLayout{distProjectRootDirectory} + ProjectConfig{..} = do requiredPkgs <- findPackageLocations True projectPackages optionalPkgs <- findPackageLocations False projectPackagesOptional @@ -541,7 +734,7 @@ (problems, pkglocs) <- partitionEithers <$> mapM (findPackageLocation required) pkglocstr unless (null problems) $ - liftIO $ throwIO $ BadPackageLocations problems + liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems return (concat pkglocs) @@ -580,6 +773,10 @@ | recognisedScheme && not (null host) -> Just (Right [ProjectPackageRemoteTarball uri]) + --TODO: [required eventually] handle file: urls which do have a null + -- host. translate URI into filepath and use ProjectPackageLocalTarball + -- or keep as file url and use ProjectPackageRemoteTarball? + | not recognisedScheme && not (null host) -> Just (Left (BadLocUnexpectedUriScheme pkglocstr)) @@ -599,7 +796,7 @@ matches <- matchFileGlob glob case matches of [] | isJust (isTrivialFilePathGlob glob) - -> return (Left (BadPackageLocationFile + -> return (Left (BadPackageLocationFile (BadLocNonexistantFile pkglocstr))) [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) @@ -607,13 +804,15 @@ _ -> do (failures, pkglocs) <- partitionEithers <$> mapM checkFilePackageMatch matches - if null pkglocs - then return (Left (BadLocGlobBadMatches pkglocstr failures)) - else return (Right pkglocs) + return $! case (failures, pkglocs) of + ([failure], []) | isJust (isTrivialFilePathGlob glob) + -> Left (BadPackageLocationFile failure) + (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) + _ -> Right pkglocs checkIsSingleFilePackage pkglocstr = do - let filename = projectRootDir pkglocstr + let filename = distProjectRootDirectory pkglocstr isFile <- liftIO $ doesFileExist filename isDir <- liftIO $ doesDirectoryExist filename if isFile || isDir @@ -629,7 +828,8 @@ -- The pkglocstr may be absolute or may be relative to the project root. -- Either way, does the right thing here. We return relative paths if -- they were relative in the first place. - let abspath = projectRootDir pkglocstr + let abspath = distProjectRootDirectory pkglocstr + isFile <- liftIO $ doesFileExist abspath isDir <- liftIO $ doesDirectoryExist abspath parentDirExists <- case takeDirectory abspath of [] -> return False @@ -650,6 +850,9 @@ | takeExtension pkglocstr == ".cabal" -> return (Right (ProjectPackageLocalCabalFile pkglocstr)) + | isFile + -> return (Left (BadLocUnexpectedFile pkglocstr)) + | parentDirExists -> return (Left (BadLocNonexistantFile pkglocstr)) @@ -691,7 +894,7 @@ -- paths. -- readSourcePackage :: Verbosity -> ProjectPackageLocation - -> Rebuild SourcePackage + -> Rebuild UnresolvedSourcePackage readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) = readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) where @@ -700,7 +903,7 @@ readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do monitorFiles [monitorFileHashed cabalFile] root <- askRoot - pkgdesc <- liftIO $ readPackageDescription verbosity (root cabalFile) + pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root cabalFile) return SourcePackage { packageInfoId = packageId pkgdesc, packageDescription = pkgdesc, @@ -718,12 +921,34 @@ data BadPerPackageCompilerPaths = BadPerPackageCompilerPaths [(PackageName, String)] +#if MIN_VERSION_base(4,8,0) deriving (Show, Typeable) +#else + deriving (Typeable) -instance Exception BadPerPackageCompilerPaths ---TODO: [required eventually] displayException for nice rendering +instance Show BadPerPackageCompilerPaths where + show = renderBadPerPackageCompilerPaths +#endif + +instance Exception BadPerPackageCompilerPaths where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadPerPackageCompilerPaths +#endif --TODO: [nice to have] custom exception subclass for Doc rendering, colour etc +renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String +renderBadPerPackageCompilerPaths + (BadPerPackageCompilerPaths ((pkgname, progname) : _)) = + "The path to the compiler program (or programs used by the compiler) " + ++ "cannot be specified on a per-package basis in the cabal.project file " + ++ "(i.e. setting the '" ++ progname ++ "-location' for package '" + ++ display pkgname ++ "'). All packages have to use the same compiler, so " + ++ "specify the path in a global 'program-locations' section." + --TODO: [nice to have] better format control so we can pretty-print the + -- offending part of the project file. Currently the line wrapping breaks any + -- formatting. +renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths" + -- | The project configuration is not allowed to specify program locations for -- programs used by the compiler as these have to be the same for each set of -- packages. @@ -744,4 +969,3 @@ , progname `Set.member` compProgNames ] of [] -> return () ps -> throwIO (BadPerPackageCompilerPaths ps) - diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveGeneric #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric #-} -- | Project configuration, implementation in terms of legacy types. -- @@ -20,17 +20,21 @@ renderPackageLocationToken, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types ( RemoteRepo(..), emptyRemoteRepo ) -import Distribution.Client.Dependency.Types - ( ConstraintSource(..) ) import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) +import Distribution.Solver.Types.ConstraintSource + import Distribution.Package import Distribution.PackageDescription - ( SourceRepo(..), RepoKind(..) ) + ( SourceRepo(..), RepoKind(..) + , dispFlagAssignment, parseFlagAssignment ) import Distribution.PackageDescription.Parse ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler @@ -39,8 +43,8 @@ ( Flag(Flag), toFlag, fromFlagOrDefault , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags - , programConfigurationPaths', splitArgs - , AllowNewer(..) ) + , programDbPaths', splitArgs + , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand , ConfigExFlags(..), configureExOptions, defaultConfigExFlags @@ -49,8 +53,6 @@ ( programName, knownPrograms ) import Distribution.Simple.Program.Db ( ProgramDb, defaultProgramDb ) -import Distribution.Client.Targets - ( dispFlagAssignment, parseFlagAssignment ) import Distribution.Simple.Utils ( lowercase ) import Distribution.Utils.NubList @@ -76,14 +78,7 @@ ( CommandUI(commandOptions), ShowOrParseArgs(..) , OptionField, option, reqArg' ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad import qualified Data.Map as Map -import Data.Char (isSpace) -import Distribution.Compat.Semigroup -import GHC.Generics (Generic) ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types @@ -242,6 +237,7 @@ projectConfigBuildOnly = configBuildOnly, projectConfigShared = configAllPackages, + projectConfigProvenance = mempty, projectConfigLocalPackages = configLocalPackages, projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } @@ -279,12 +275,14 @@ } = globalFlags ConfigFlags { + configDistPref = projectConfigDistDir, configHcFlavor = projectConfigHcFlavor, configHcPath = projectConfigHcPath, configHcPkg = projectConfigHcPkg, --configInstallDirs = projectConfigInstallDirs, --configUserInstall = projectConfigUserInstall, --configPackageDBs = projectConfigPackageDBs, + configAllowOlder = projectConfigAllowOlder, configAllowNewer = projectConfigAllowNewer } = configFlags @@ -296,16 +294,21 @@ } = configExFlags InstallFlags { + installProjectFileName = projectConfigProjectFile, installHaddockIndex = projectConfigHaddockIndex, --installReinstall = projectConfigReinstall, --installAvoidReinstalls = projectConfigAvoidReinstalls, --installOverrideReinstall = projectConfigOverrideReinstall, + installIndexState = projectConfigIndexState, installMaxBackjumps = projectConfigMaxBackjumps, --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, + installPerComponent = projectConfigPerComponent, --installIndependentGoals = projectConfigIndependentGoals, --installShadowPkgs = projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls } = installFlags @@ -364,6 +367,7 @@ haddockHoogle = packageConfigHaddockHoogle, haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, + haddockForeignLibs = packageConfigHaddockForeignLibs, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, haddockBenchmarks = packageConfigHaddockBenchmarks, @@ -389,7 +393,7 @@ GlobalFlags { globalCacheDir = projectConfigCacheDir, globalLogsDir = projectConfigLogsDir, - globalWorldFile = projectConfigWorldFile, + globalWorldFile = _, globalHttpTransport = projectConfigHttpTransport, globalIgnoreExpiry = projectConfigIgnoreExpiry } = globalFlags @@ -402,7 +406,7 @@ installDryRun = projectConfigDryRun, installOnly = _, installOnlyDeps = projectConfigOnlyDeps, - installRootCmd = projectConfigRootCmd, + installRootCmd = _, installSummaryFile = projectConfigSummaryFile, installLogFile = projectConfigLogFile, installBuildReports = projectConfigBuildReports, @@ -410,6 +414,7 @@ installSymlinkBinDir = projectConfigSymlinkBinDir, installOneShot = projectConfigOneShot, installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, installOfflineMode = projectConfigOfflineMode } = installFlags @@ -465,15 +470,18 @@ globalCacheDir = projectConfigCacheDir, globalLocalRepos = projectConfigLocalRepos, globalLogsDir = projectConfigLogsDir, - globalWorldFile = projectConfigWorldFile, + globalWorldFile = mempty, globalRequireSandbox = mempty, globalIgnoreSandbox = mempty, globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport + globalHttpTransport = projectConfigHttpTransport, + globalNix = mempty } configFlags = mempty { configVerbosity = projectConfigVerbosity, + configDistPref = projectConfigDistDir, + configAllowOlder = projectConfigAllowOlder, configAllowNewer = projectConfigAllowNewer } @@ -494,21 +502,27 @@ installMaxBackjumps = projectConfigMaxBackjumps, installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, + installCountConflicts = projectConfigCountConflicts, installIndependentGoals = mempty, --projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, installOnly = mempty, installOnlyDeps = projectConfigOnlyDeps, - installRootCmd = projectConfigRootCmd, + installIndexState = projectConfigIndexState, + installRootCmd = mempty, --no longer supported installSummaryFile = projectConfigSummaryFile, installLogFile = projectConfigLogFile, installBuildReports = projectConfigBuildReports, installReportPlanningFailure = projectConfigReportPlanningFailure, installSymlinkBinDir = projectConfigSymlinkBinDir, + installPerComponent = projectConfigPerComponent, installOneShot = projectConfigOneShot, installNumJobs = projectConfigNumJobs, + installKeepGoing = projectConfigKeepGoing, installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode + installOfflineMode = projectConfigOfflineMode, + installProjectFileName = projectConfigProjectFile } @@ -526,6 +540,7 @@ } where configFlags = ConfigFlags { + configArgs = mempty, configPrograms_ = mempty, configProgramPaths = mempty, configProgramArgs = mempty, @@ -533,6 +548,7 @@ configHcFlavor = projectConfigHcFlavor, configHcPath = projectConfigHcPath, configHcPkg = projectConfigHcPkg, + configInstantiateWith = mempty, configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, @@ -548,6 +564,7 @@ configInstallDirs = mempty, configScratchDir = mempty, configDistPref = mempty, + configCabalFilePath = mempty, configVerbosity = mempty, configUserInstall = mempty, --projectConfigUserInstall, configPackageDBs = mempty, --projectConfigPackageDBs, @@ -560,7 +577,9 @@ configConstraints = mempty, configDependencies = mempty, configExtraIncludeDirs = mempty, + configDeterministic = mempty, configIPID = mempty, + configCID = mempty, configConfigurationsFlags = mempty, configTests = mempty, configCoverage = mempty, --TODO: don't merge @@ -570,6 +589,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = mempty, configDebugInfo = mempty, + configAllowOlder = mempty, configAllowNewer = mempty } @@ -587,6 +607,7 @@ } where configFlags = ConfigFlags { + configArgs = mempty, configPrograms_ = configPrograms_ mempty, configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), @@ -594,6 +615,7 @@ configHcFlavor = mempty, configHcPath = mempty, configHcPkg = mempty, + configInstantiateWith = mempty, configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, @@ -609,6 +631,7 @@ configInstallDirs = mempty, configScratchDir = mempty, configDistPref = mempty, + configCabalFilePath = mempty, configVerbosity = mempty, configUserInstall = mempty, configPackageDBs = mempty, @@ -622,6 +645,8 @@ configDependencies = mempty, configExtraIncludeDirs = packageConfigExtraIncludeDirs, configIPID = mempty, + configCID = mempty, + configDeterministic = mempty, configConfigurationsFlags = packageConfigFlagAssignment, configTests = packageConfigTests, configCoverage = packageConfigCoverage, --TODO: don't merge @@ -631,6 +656,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = packageConfigRelocatable, configDebugInfo = packageConfigDebugInfo, + configAllowOlder = mempty, configAllowNewer = mempty } @@ -646,6 +672,7 @@ haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, haddockForHackage = mempty, --TODO: added recently + haddockForeignLibs = packageConfigHaddockForeignLibs, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, haddockBenchmarks = packageConfigHaddockBenchmarks, @@ -773,7 +800,7 @@ ] . filterFields [ "remote-repo-cache" - , "logs-dir", "world-file", "ignore-expiry", "http-transport" + , "logs-dir", "ignore-expiry", "http-transport" ] . commandOptionsToFields ) (commandOptions (globalCommand []) ParseArgs) @@ -782,11 +809,18 @@ legacyConfigureShFlags (\flags conf -> conf { legacyConfigureShFlags = flags }) . addFields + [ simpleField "allow-older" + (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) + ] + . addFields [ simpleField "allow-newer" - (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer) - configAllowNewer (\v conf -> conf { configAllowNewer = v }) + (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) ] - . filterFields ["verbose"] + . filterFields ["verbose", "builddir" ] . commandOptionsToFields ) (configureOptions ParseArgs) ++ @@ -823,26 +857,27 @@ , "root-cmd", "symlink-bindir" , "build-log" , "remote-build-reporting", "report-planning-failure" - , "one-shot", "jobs", "offline" + , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: - , "max-backjumps", "reorder-goals", "strong-flags" + , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags" + , "allow-boot-library-installs", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" -parseAllowNewer :: ReadP r AllowNewer -parseAllowNewer = - ((const AllowNewerNone <$> (Parse.string "none" +++ Parse.string "None")) - +++ (const AllowNewerAll <$> (Parse.string "all" +++ Parse.string "All"))) - <++ ( AllowNewerSome <$> parseOptCommaList parse) +parseRelaxDeps :: ReadP r RelaxDeps +parseRelaxDeps = + ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None")) + +++ (const RelaxDepsAll <$> (Parse.string "all" +++ Parse.string "All"))) + <++ ( RelaxDepsSome <$> parseOptCommaList parse) -dispAllowNewer :: AllowNewer -> Doc -dispAllowNewer AllowNewerNone = Disp.text "None" -dispAllowNewer (AllowNewerSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma - . map disp $ pkgs -dispAllowNewer AllowNewerAll = Disp.text "All" +dispRelaxDeps :: RelaxDeps -> Doc +dispRelaxDeps RelaxDepsNone = Disp.text "None" +dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma + . map disp $ pkgs +dispRelaxDeps RelaxDepsAll = Disp.text "All" legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] @@ -877,13 +912,13 @@ (\v conf -> conf { configConfigurationsFlags = v }) ] . filterFields - [ "compiler", "with-compiler", "with-hc-pkg" + [ "with-compiler", "with-hc-pkg" , "program-prefix", "program-suffix" , "library-vanilla", "library-profiling" , "shared", "executable-dynamic" , "profiling", "executable-profiling" , "profiling-detail", "library-profiling-detail" - , "optimization", "debug-info", "library-for-ghci", "split-objs" + , "library-for-ghci", "split-objs" , "executable-stripping", "library-stripping" , "tests", "benchmarks" , "coverage", "library-coverage" @@ -919,6 +954,7 @@ ("haddock-"++) . filterFields [ "hoogle", "html", "html-location" + , "foreign-libraries" , "executables", "tests", "benchmarks", "all", "internal", "css" , "hyperlink-source", "hscolour-css" , "contents-location", "keep-temp-files" @@ -1081,11 +1117,11 @@ programOptionsFieldDescrs :: (a -> [(String, [String])]) -> ([(String, [String])] -> a -> a) -> [FieldDescr a] -programOptionsFieldDescrs get set = +programOptionsFieldDescrs get' set = commandOptionsToFields - $ programConfigurationOptions + $ programDbOptions defaultProgramDb - ParseArgs get set + ParseArgs get' set programOptionsSectionDescr :: SectionDescr LegacyPackageConfig programOptionsSectionDescr = @@ -1110,7 +1146,7 @@ programLocationsFieldDescrs :: [FieldDescr ConfigFlags] programLocationsFieldDescrs = commandOptionsToFields - $ programConfigurationPaths' + $ programDbPaths' (++ "-location") defaultProgramDb ParseArgs @@ -1136,25 +1172,25 @@ } --- | For each known program @PROG@ in 'progConf', produce a @PROG-options@ +-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ -- 'OptionField'. -programConfigurationOptions +programDbOptions :: ProgramDb -> ShowOrParseArgs -> (flags -> [(String, [String])]) -> ([(String, [String])] -> (flags -> flags)) -> [OptionField flags] -programConfigurationOptions progConf showOrParseArgs get set = +programDbOptions progDb showOrParseArgs get' set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: ShowArgs -> [programOptions "PROG"] ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progConf) + (knownPrograms progDb) where programOptions prog = option "" [prog ++ "-options"] ("give extra options to " ++ prog) - get set + get' set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (\progArgs -> [ joinsArgs args | (prog', args) <- progArgs, prog==prog' ])) @@ -1213,11 +1249,11 @@ -- of parseOptCommaList below listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listFieldWithSep separator name showF readF get set = - liftField get set' $ +listFieldWithSep separator name showF readF get' set = + liftField get' set' $ ParseUtils.field name showF' (parseOptCommaList readF) where - set' xs b = set (get b ++ xs) b + set' xs b = set (get' b ++ xs) b showF' = separator . map showF --TODO: [code cleanup] local redefinition that should replace the version in diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -8,6 +8,7 @@ ProjectConfig(..), ProjectConfigBuildOnly(..), ProjectConfigShared(..), + ProjectConfigProvenance(..), PackageConfig(..), -- * Resolving configuration @@ -22,14 +23,21 @@ import Distribution.Client.Types ( RemoteRepo ) import Distribution.Client.Dependency.Types - ( PreSolver, ConstraintSource ) + ( PreSolver ) import Distribution.Client.Targets ( UserConstraint ) -import Distribution.Client.BuildReports.Types +import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) +import Distribution.Client.IndexUtils.Timestamp + ( IndexState ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ConstraintSource + import Distribution.Package - ( PackageName, PackageId, UnitId, Dependency ) + ( PackageName, PackageId, UnitId ) +import Distribution.Types.Dependency import Distribution.Version ( Version ) import Distribution.System @@ -40,7 +48,7 @@ ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup - ( Flag, AllowNewer(..) ) + ( Flag, AllowNewer(..), AllowOlder(..) ) import Distribution.Simple.InstallDirs ( PathTemplate ) import Distribution.Utils.NubList @@ -50,9 +58,11 @@ import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import Distribution.Compat.Binary (Binary) import Distribution.Compat.Semigroup import GHC.Generics (Generic) +import Data.Typeable ------------------------------- @@ -80,14 +90,15 @@ = ProjectConfig { -- | Packages in this project, including local dirs, local .cabal files - -- local and remote tarballs. Where these are file globs, they must - -- match something. + -- local and remote tarballs. When these are file globs, they must + -- match at least one package. projectPackages :: [String], -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that -- file globs are allowed to match nothing. The primary use case for -- this is to be able to say @optional-packages: */@ to automagically - -- pick up deps that we unpack locally. + -- pick up deps that we unpack locally without erroring when + -- there aren't any. projectPackagesOptional :: [String], -- | Packages in this project from remote source repositories. @@ -96,12 +107,18 @@ -- | Packages in this project from hackage repositories. projectPackagesNamed :: [Dependency], + -- See respective types for an explanation of what these + -- values are about: projectConfigBuildOnly :: ProjectConfigBuildOnly, projectConfigShared :: ProjectConfigShared, + projectConfigProvenance :: Set ProjectConfigProvenance, + + -- | Configuration to be applied to *local* packages; i.e., + -- any packages which are explicitly named in `cabal.project`. projectConfigLocalPackages :: PackageConfig, projectConfigSpecificPackage :: MapMappend PackageName PackageConfig } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Typeable) -- | That part of the project configuration that only affects /how/ we build -- and not the /value/ of the things we build. This means this information @@ -120,14 +137,13 @@ projectConfigSymlinkBinDir :: Flag FilePath, projectConfigOneShot :: Flag Bool, projectConfigNumJobs :: Flag (Maybe Int), + projectConfigKeepGoing :: Flag Bool, projectConfigOfflineMode :: Flag Bool, projectConfigKeepTempFiles :: Flag Bool, projectConfigHttpTransport :: Flag String, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath, - projectConfigWorldFile :: Flag FilePath, - projectConfigRootCmd :: Flag String + projectConfigLogsDir :: Flag FilePath } deriving (Eq, Show, Generic) @@ -137,6 +153,8 @@ -- data ProjectConfigShared = ProjectConfigShared { + projectConfigDistDir :: Flag FilePath, + projectConfigProjectFile :: Flag FilePath, projectConfigHcFlavor :: Flag CompilerFlavor, projectConfigHcPath :: Flag FilePath, projectConfigHcPkg :: Flag FilePath, @@ -153,20 +171,25 @@ -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, + projectConfigIndexState :: Flag IndexState, -- solver configuration projectConfigConstraints :: [(UserConstraint, ConstraintSource)], projectConfigPreferences :: [Dependency], projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused projectConfigSolver :: Flag PreSolver, + projectConfigAllowOlder :: Maybe AllowOlder, projectConfigAllowNewer :: Maybe AllowNewer, projectConfigMaxBackjumps :: Flag Int, - projectConfigReorderGoals :: Flag Bool, - projectConfigStrongFlags :: Flag Bool + projectConfigReorderGoals :: Flag ReorderGoals, + projectConfigCountConflicts :: Flag CountConflicts, + projectConfigStrongFlags :: Flag StrongFlags, + projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, + projectConfigPerComponent :: Flag Bool -- More things that only make sense for manual mode, not --local mode -- too much control! - --projectConfigIndependentGoals :: Flag Bool, + --projectConfigIndependentGoals :: Flag IndependentGoals, --projectConfigShadowPkgs :: Flag Bool, --projectConfigReinstall :: Flag Bool, --projectConfigAvoidReinstalls :: Flag Bool, @@ -176,6 +199,21 @@ deriving (Eq, Show, Generic) +-- | Specifies the provenance of project configuration, whether defaults were +-- used or if the configuration was read from an explicit file path. +data ProjectConfigProvenance + + -- | The configuration is implicit due to no explicit configuration + -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig' + -- for how implicit configuration is determined. + = Implicit + + -- | The path the project configuration was explicitly read from. + -- | The configuration was explicitly read from the specified 'FilePath'. + | Explicit FilePath + deriving (Eq, Ord, Show, Generic) + + -- | Project configuration that is specific to each package, that is where we -- can in principle have different values for different packages in the same -- project. @@ -215,6 +253,7 @@ packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this + packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this @@ -229,13 +268,14 @@ instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly instance Binary ProjectConfigShared +instance Binary ProjectConfigProvenance instance Binary PackageConfig -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. newtype MapLast k v = MapLast { getMapLast :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary) + deriving (Eq, Show, Functor, Generic, Binary, Typeable) instance Ord k => Monoid (MapLast k v) where mempty = MapLast Map.empty @@ -249,7 +289,7 @@ -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that -- 'mappend's values of overlapping keys rather than taking the first. newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } - deriving (Eq, Show, Functor, Generic, Binary) + deriving (Eq, Show, Functor, Generic, Binary, Typeable) instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where mempty = MapMappend Map.empty @@ -313,20 +353,24 @@ solverSettingFlagAssignments :: Map PackageName FlagAssignment, solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused solverSettingSolver :: PreSolver, + solverSettingAllowOlder :: AllowOlder, solverSettingAllowNewer :: AllowNewer, solverSettingMaxBackjumps :: Maybe Int, - solverSettingReorderGoals :: Bool, - solverSettingStrongFlags :: Bool + solverSettingReorderGoals :: ReorderGoals, + solverSettingCountConflicts :: CountConflicts, + solverSettingStrongFlags :: StrongFlags, + solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, + solverSettingIndexState :: IndexState -- Things that only make sense for manual mode, not --local mode -- too much control! - --solverSettingIndependentGoals :: Bool, + --solverSettingIndependentGoals :: IndependentGoals, --solverSettingShadowPkgs :: Bool, --solverSettingReinstall :: Bool, --solverSettingAvoidReinstalls :: Bool, --solverSettingOverrideReinstall :: Bool, --solverSettingUpgradeDeps :: Bool } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Typeable) instance Binary SolverSettings @@ -354,13 +398,13 @@ buildSettingSymlinkBinDir :: [FilePath], buildSettingOneShot :: Bool, buildSettingNumJobs :: Int, + buildSettingKeepGoing :: Bool, buildSettingOfflineMode :: Bool, buildSettingKeepTempFiles :: Bool, buildSettingRemoteRepos :: [RemoteRepo], buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, - buildSettingIgnoreExpiry :: Bool, - buildSettingRootCmd :: Maybe String + buildSettingIgnoreExpiry :: Bool } diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -- | This module deals with building and incrementally rebuilding a collection -- of packages. It is what backs the @cabal build@ and @configure@ commands, @@ -38,152 +40,235 @@ -- 'ElaboratedInstallPlan'. -- module Distribution.Client.ProjectOrchestration ( + -- * Discovery phase: what is in the project? + establishProjectBaseContext, + ProjectBaseContext(..), + BuildTimeSettings(..), + commandLineFlagsToProjectConfig, + -- * Pre-build phase: decide what to do. runProjectPreBuildPhase, - CliConfigFlags, - PreBuildHooks(..), ProjectBuildContext(..), + -- ** Selecting what targets we mean + readTargetSelectors, + reportTargetSelectorProblems, + resolveTargets, + TargetsMap, + TargetSelector(..), + PackageId, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentName(..), + ComponentKind(..), + ComponentTarget(..), + SubComponentTarget(..), + TargetProblemCommon(..), + selectComponentTargetBasic, + distinctTargetComponents, + -- ** Utils for selecting targets + filterTargetsKind, + filterTargetsKindWith, + selectBuildableTargets, + selectBuildableTargetsWith, + selectBuildableTargets', + selectBuildableTargetsWith', + forgetTargetsDetail, + -- ** Adjusting the plan - selectTargets, + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), printPlan, -- * Build phase: now do it. runProjectBuildPhase, -- * Post build actions - reportBuildFailures, + runProjectPostBuildPhase, + dieOnBuildFailures, + + -- * Shared CLI utils + cmdCommonHelpTextNewBuildBeta, ) where import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning + hiding ( pruneInstallPlanToTargets ) +import qualified Distribution.Client.ProjectPlanning as ProjectPlanning + ( pruneInstallPlanToTargets ) +import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) + ( GenericReadyPackage(..), UnresolvedSourcePackage ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.BuildTarget - ( UserBuildTarget, resolveUserBuildTargets - , BuildTarget(..), buildTargetPackage ) +import Distribution.Client.TargetSelector + ( TargetSelector(..) + , ComponentKind(..), componentKind + , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.DistDirLayout import Distribution.Client.Config (defaultCabalDir) import Distribution.Client.Setup hiding (packageName) +import Distribution.Solver.Types.OptionalStanza + import Distribution.Package hiding (InstalledPackageId, installedPackageId) -import qualified Distribution.PackageDescription as PD -import Distribution.PackageDescription (FlagAssignment) -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.Setup (HaddockFlags) +import Distribution.PackageDescription (FlagAssignment, showFlagValue) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), pkgComponents ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command (commandShowOptions) -import Distribution.Simple.Utils (die, notice) +import Distribution.Simple.Utils + ( die' + , notice, noticeNoWrap, debugNoWrap ) import Distribution.Verbosity import Distribution.Text +import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map (Map) import Data.List +import Data.Maybe import Data.Either -import System.Exit (exitFailure) +import Control.Exception (Exception(..), throwIO, assert) +import System.Exit (ExitCode(..), exitFailure) +#ifdef MIN_VERSION_unix +import System.Posix.Signals (sigKILL, sigSEGV) +#endif --- | Command line configuration flags. These are used to extend\/override the --- project configuration. +-- | This holds the context of a project prior to solving: the content of the +-- @cabal.project@ and all the local package @.cabal@ files. -- -type CliConfigFlags = ( GlobalFlags - , ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags ) +data ProjectBaseContext = ProjectBaseContext { + distDirLayout :: DistDirLayout, + cabalDirLayout :: CabalDirLayout, + projectConfig :: ProjectConfig, + localPackages :: [UnresolvedSourcePackage], + buildSettings :: BuildTimeSettings + } --- | Hooks to alter the behaviour of 'runProjectPreBuildPhase'. --- --- For example the @configure@, @build@ and @repl@ commands use this to get --- their different behaviour. --- -data PreBuildHooks = PreBuildHooks { - hookPrePlanning :: FilePath - -> DistDirLayout +establishProjectBaseContext :: Verbosity -> ProjectConfig - -> IO (), - hookSelectPlanSubset :: ElaboratedInstallPlan - -> IO ElaboratedInstallPlan - } + -> IO ProjectBaseContext +establishProjectBaseContext verbosity cliConfig = do --- | This holds the context between the pre-build and build phases. + cabalDir <- defaultCabalDir + projectRoot <- either throwIO return =<< + findProjectRoot Nothing mprojectFile + + let cabalDirLayout = defaultCabalDirLayout cabalDir + distDirLayout = defaultDistDirLayout projectRoot + mdistDirectory + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + distDirLayout + cliConfig + + let buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } + where + mdistDirectory = Setup.flagToMaybe projectConfigDistDir + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared { + projectConfigDistDir, + projectConfigProjectFile + } = projectConfigShared cliConfig + + +-- | This holds the context between the pre-build, build and post-build phases. -- data ProjectBuildContext = ProjectBuildContext { - distDirLayout :: DistDirLayout, - elaboratedPlan :: ElaboratedInstallPlan, - elaboratedShared :: ElaboratedSharedConfig, - pkgsBuildStatus :: BuildStatusMap, - buildSettings :: BuildTimeSettings + -- | This is the improved plan, before we select a plan subset based on + -- the build targets, and before we do the dry-run. So this contains + -- all packages in the project. + elaboratedPlanOriginal :: ElaboratedInstallPlan, + + -- | This is the 'elaboratedPlanOriginal' after we select a plan subset + -- and do the dry-run phase to find out what is up-to or out-of date. + -- This is the plan that will be executed during the build phase. So + -- this contains only a subset of packages in the project. + elaboratedPlanToExecute:: ElaboratedInstallPlan, + + -- | The part of the install plan that's shared between all packages in + -- the plan. This does not change between the two plan variants above, + -- so there is just the one copy. + elaboratedShared :: ElaboratedSharedConfig, + + -- | The result of the dry-run phase. This tells us about each member of + -- the 'elaboratedPlanToExecute'. + pkgsBuildStatus :: BuildStatusMap } -- | Pre-build phase: decide what to do. -- -runProjectPreBuildPhase :: Verbosity - -> CliConfigFlags - -> PreBuildHooks - -> IO ProjectBuildContext runProjectPreBuildPhase + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan) + -> IO ProjectBuildContext +runProjectPreBuildPhase verbosity - ( globalFlags - , configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks{..} = do - - cabalDir <- defaultCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir - - projectRootDir <- findProjectRoot - let distDirLayout = defaultDistDirLayout projectRootDir - - let cliConfig = commandLineFlagsToProjectConfig - globalFlags configFlags configExFlags - installFlags haddockFlags - - hookPrePlanning - projectRootDir - distDirLayout - cliConfig + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + selectPlanSubset = do -- Take the project configuration and make a plan for how to build -- everything in the project. This is independent of any specific targets -- the user has asked for. -- - (elaboratedPlan, elaboratedShared, projectConfig) <- + (elaboratedPlan, _, elaboratedShared) <- rebuildInstallPlan verbosity - projectRootDir distDirLayout cabalDirLayout - cliConfig - - let buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - (projectConfigShared projectConfig) - (projectConfigBuildOnly projectConfig) - (projectConfigBuildOnly cliConfig) + distDirLayout cabalDirLayout + projectConfig + localPackages -- The plan for what to do is represented by an 'ElaboratedInstallPlan' -- Now given the specific targets the user has asked for, decide -- which bits of the plan we will want to execute. -- - elaboratedPlan' <- hookSelectPlanSubset elaboratedPlan + elaboratedPlan' <- selectPlanSubset elaboratedPlan - -- Check if any packages don't need rebuilding, and improve the plan. + -- Check which packages need rebuilding. -- This also gives us more accurate reasons for the --dry-run output. -- - (elaboratedPlan'', pkgsBuildStatus) <- - rebuildTargetsDryRun distDirLayout - elaboratedPlan' + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared + elaboratedPlan' + -- Improve the plan by marking up-to-date packages as installed. + -- + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + return ProjectBuildContext { - distDirLayout, - elaboratedPlan = elaboratedPlan'', + elaboratedPlanOriginal = elaboratedPlan, + elaboratedPlanToExecute = elaboratedPlan'', elaboratedShared, - pkgsBuildStatus, - buildSettings + pkgsBuildStatus } @@ -193,16 +278,70 @@ -- rebuild the various packages needed. -- runProjectBuildPhase :: Verbosity + -> ProjectBaseContext -> ProjectBuildContext - -> IO ElaboratedInstallPlan -runProjectBuildPhase verbosity ProjectBuildContext {..} = + -> IO BuildOutcomes +runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ + | buildSettingDryRun buildSettings + = return Map.empty + +runProjectBuildPhase verbosity + ProjectBaseContext{..} ProjectBuildContext {..} = + fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ rebuildTargets verbosity distDirLayout - elaboratedPlan + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlanToExecute elaboratedShared pkgsBuildStatus buildSettings + where + previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes + previousBuildOutcomes = + Map.mapMaybe $ \status -> case status of + BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) + --TODO: [nice to have] record build failures persistently + _ -> Nothing +-- | Post-build phase: various administrative tasks +-- +-- Update bits of state based on the build outcomes and report any failures. +-- +runProjectPostBuildPhase :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> BuildOutcomes + -> IO () +runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ + | buildSettingDryRun buildSettings + = return () + +runProjectPostBuildPhase verbosity + ProjectBaseContext {..} ProjectBuildContext {..} + buildOutcomes = do + -- Update other build artefacts + -- TODO: currently none, but could include: + -- - bin symlinks/wrappers + -- - haddock/hoogle/ctags indexes + -- - delete stale lib registrations + -- - delete stale package dirs + + postBuildStatus <- updatePostBuildProjectStatus + verbosity + distDirLayout + elaboratedPlanOriginal + pkgsBuildStatus + buildOutcomes + + writePlanGhcEnvironment distDirLayout + elaboratedPlanOriginal + elaboratedShared + postBuildStatus + + -- Finally if there were any build failures then report them and throw + -- an exception to terminate the program + dieOnBuildFailures verbosity elaboratedPlanToExecute buildOutcomes + -- Note that it is a deliberate design choice that the 'buildTargets' is -- not passed to phase 1, and the various bits of input config is not -- passed to phase 2. @@ -224,25 +363,62 @@ -- Taking targets into account, selecting what to build -- --- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it --- required to build the given user targets. +-- | The set of components to build, represented as a mapping from 'UnitId's +-- to the 'ComponentTarget's within the unit that will be selected +-- (e.g. selected to build, test or repl). -- --- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable. +-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that +-- matched this target. Typically this is exactly one, but in general it is +-- possible to for different selectors to match the same target. This extra +-- information is primarily to help make helpful error messages. -- -selectTargets :: PackageTarget - -> (ComponentTarget -> PackageTarget) - -> [UserBuildTarget] - -> ElaboratedInstallPlan - -> IO ElaboratedInstallPlan -selectTargets targetDefaultComponents targetSpecificComponent - userBuildTargets installPlan = do - - -- Match the user targets against the available targets. If no targets are - -- given this uses the package in the current directory, if any. - -- - buildTargets <- resolveUserBuildTargets localPackages userBuildTargets - --TODO: [required eventually] report something if there are no targets +type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] +-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and +-- 'ComponentTarget's they ought to refer to. +-- +-- The idea is that every user target identifies one or more roots in the +-- 'ElaboratedInstallPlan', which we will use to determine the closure +-- of what packages need to be built, dropping everything from the plan +-- that is unnecessary. This closure and pruning is done by +-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms +-- of 'UnitId's and the 'ComponentTarget's within those. +-- +-- This means we first need to translate the 'TargetSelector's into the +-- 'UnitId's and 'ComponentTarget's. This translation has to be different for +-- the different command line commands, like @build@, @repl@ etc. For example +-- the command @build pkgfoo@ could select a different set of components in +-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and +-- all executables, whereas @repl@ would select the library or a single +-- executable. Furthermore, both of these examples could fail, and fail in +-- different ways and each needs to be able to produce helpful error messages. +-- +-- So 'resolveTargets' takes two helpers: one to select the targets to be used +-- by user targets that refer to a whole package ('TargetPackage'), and +-- another to check user targets that refer to a component (or a module or +-- file within a component). These helpers can fail, and use their own error +-- type. Both helpers get given the 'AvailableTarget' info about the +-- component(s). +-- +-- While commands vary quite a bit in their behaviour about which components to +-- select for a whole-package target, most commands have the same behaviour for +-- checking a user target that refers to a specific component. To help with +-- this commands can use 'selectComponentTargetBasic', either directly or as +-- a basis for their own @selectComponentTarget@ implementation. +-- +resolveTargets :: forall err. + (forall k. TargetSelector PackageId + -> [AvailableTarget k] + -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k + -> Either err k ) + -> (TargetProblemCommon -> err) + -> ElaboratedInstallPlan + -> [TargetSelector PackageId] + -> Either [err] TargetsMap +resolveTargets selectPackageTargets selectComponentTarget liftProblem + installPlan targetSelectors = --TODO: [required eventually] -- we cannot resolve names of packages other than those that are -- directly in the current plan. We ought to keep a set of the known @@ -250,124 +426,192 @@ -- really need that until we can do something sensible with packages -- outside of the project. - -- Now check if those targets belong to the current project or not. - -- Ultimately we want to do something sensible for targets not in this - -- project, but for now we just bail. This gives us back the ipkgid from - -- the plan. - -- - buildTargets' <- either reportBuildTargetProblems return - $ resolveAndCheckTargets - targetDefaultComponents - targetSpecificComponent - installPlan - buildTargets - - -- Finally, prune the install plan to cover just those target packages - -- and their deps. - -- - return (pruneInstallPlanToTargets buildTargets' installPlan) - where - localPackages = - [ (pkgDescription pkg, pkgSourceLocation pkg) - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan ] - --TODO: [code cleanup] is there a better way to identify local packages? - - + case partitionEithers + [ fmap ((,) targetSelector) (checkTarget targetSelector) + | targetSelector <- targetSelectors ] of + ([], targets) -> Right + . Map.map nubComponentTargets + $ Map.fromListWith (++) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] -resolveAndCheckTargets :: PackageTarget - -> (ComponentTarget -> PackageTarget) - -> ElaboratedInstallPlan - -> [BuildTarget PackageName] - -> Either [BuildTargetProblem] - (Map InstalledPackageId [PackageTarget]) -resolveAndCheckTargets targetDefaultComponents - targetSpecificComponent - installPlan targets = - case partitionEithers (map checkTarget targets) of - ([], targets') -> Right $ Map.fromListWith (++) - [ (ipkgid, [t]) | (ipkgid, t) <- targets' ] - (problems, _) -> Left problems + (problems, _) -> Left problems where -- TODO [required eventually] currently all build targets refer to packages -- inside the project. Ultimately this has to be generalised to allow -- referring to other packages and targets. + checkTarget :: TargetSelector PackageId + -> Either err [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency - checkTarget (BuildTargetPackage pn) - | Just ipkgid <- Map.lookup pn projAllPkgs - = Right (ipkgid, targetDefaultComponents) - - -- But if we ask to build an individual component, then that component - -- had better be in a package that is local to the project. - -- TODO: and if it's an optional stanza, then that stanza must be available - checkTarget t@(BuildTargetComponent pn cn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, targetSpecificComponent - (ComponentTarget cn WholeComponent)) - - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + checkTarget bt@(TargetPackage _ pkgid mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgid availableTargetsByPackage + = case selectPackageTargets bt ats of + Left e -> Left e + Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) + | (unitid, cname) <- ts ] - checkTarget t@(BuildTargetModule pn cn mn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn))) + | otherwise + = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + checkTarget bt@(TargetAllPackages mkfilter) = + let ats = maybe id filterTargetsKind mkfilter + $ filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackage) + in case selectPackageTargets bt ats of + Left e -> Left e + Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) + | (unitid, cname) <- ts ] - checkTarget t@(BuildTargetFile pn cn fn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn))) + checkTarget (TargetComponent pkgid cname subtarget) + | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent + = case partitionEithers + (map (selectComponentTarget pkgid cname subtarget) ats) of + (e:_,_) -> Left e + ([],ts) -> Right [ (unitid, ctarget) + | let ctarget = ComponentTarget cname subtarget + , (unitid, _) <- ts ] - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + | Map.member pkgid availableTargetsByPackage + = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) - checkTarget t - = Left (BuildTargetNotInProject (buildTargetPackage t)) + | otherwise + = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) + --TODO: check if the package is in the plan, even if it's not local + --TODO: check if the package is in hackage and return different + -- error cases here so the commands can handle things appropriately - projAllPkgs, projLocalPkgs :: Map PackageName InstalledPackageId - projAllPkgs = - Map.fromList - [ (packageName pkg, installedPackageId pkg) - | pkg <- InstallPlan.toList installPlan ] + availableTargetsByPackage :: Map PackageId [AvailableTarget (UnitId, ComponentName)] + availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] + availableTargetsByComponent = availableTargets installPlan + availableTargetsByPackage = Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByComponent + `Map.union` availableTargetsEmptyPackages - projLocalPkgs = + -- Add in all the empty packages. These do not appear in the + -- availableTargetsByComponent map, since that only contains components + -- so packages with no components are invisible from that perspective. + -- The empty packages need to be there for proper error reporting, so users + -- can select the empty package and then we can report that it is empty, + -- otherwise we falsely report there is no such package at all. + availableTargetsEmptyPackages = Map.fromList - [ (packageName pkg, installedPackageId pkg) + [ (packageId pkg, []) | InstallPlan.Configured pkg <- InstallPlan.toList installPlan - , case pkgSourceLocation pkg of - LocalUnpackedPackage _ -> True; _ -> False - --TODO: [code cleanup] is there a better way to identify local packages? + , case elabPkgOrComp pkg of + ElabComponent _ -> False + ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) ] --TODO: [research required] what if the solution has multiple versions of this package? -- e.g. due to setup deps or due to multiple independent sets of -- packages being built (e.g. ghc + ghcjs in a project) -data BuildTargetProblem - = BuildTargetNotInProject PackageName - | BuildTargetComponentNotProjectLocal (BuildTarget PackageName) - | BuildTargetOptionalStanzaDisabled Bool - -- ^ @True@: explicitly disabled by user - -- @False@: disabled by solver +filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKind ckind = filterTargetsKindWith (== ckind) -reportBuildTargetProblems :: [BuildTargetProblem] -> IO a -reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem +filterTargetsKindWith :: (ComponentKind -> Bool) + -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKindWith p ts = + [ t | t@(AvailableTarget _ cname _ _) <- ts + , p (componentKind cname) ] -reportBuildTargetProblem :: BuildTargetProblem -> String -reportBuildTargetProblem (BuildTargetNotInProject pn) = - "Cannot build the package " ++ display pn ++ ", it is not in this project." - ++ "(either directly or indirectly). If you want to add it to the " - ++ "project then edit the cabal.project file." +selectBuildableTargets :: [AvailableTarget k] -> [k] +selectBuildableTargets ts = + [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] -reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) = - "The package " ++ display (buildTargetPackage t) ++ " is in the " - ++ "project but it is not a locally unpacked package, so " +selectBuildableTargetsWith :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> [k] +selectBuildableTargetsWith p ts = + [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] -reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined +selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargets' ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ] +selectBuildableTargetsWith' :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargetsWith' p ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ] + +forgetTargetDetail :: AvailableTarget k -> AvailableTarget () +forgetTargetDetail = fmap (const ()) + +forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] +forgetTargetsDetail = map forgetTargetDetail + +-- | A basic @selectComponentTarget@ implementation to use or pass to +-- 'resolveTargets', that does the basic checks that the component is +-- buildable and isn't a test suite or benchmark that is disabled. This +-- can also be used to do these basic checks as part of a custom impl that +-- +selectComponentTargetBasic :: PackageId + -> ComponentName + -> SubComponentTarget + -> AvailableTarget k + -> Either TargetProblemCommon k +selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} = + case availableTargetStatus of + TargetDisabledByUser -> + Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) + + TargetDisabledBySolver -> + Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) + + TargetNotLocal -> + Left (TargetComponentNotProjectLocal pkgid cname subtarget) + + TargetNotBuildable -> + Left (TargetComponentNotBuildable pkgid cname subtarget) + + TargetBuildable targetKey _ -> + Right targetKey + +data TargetProblemCommon + = TargetNotInProject PackageName + | TargetComponentNotProjectLocal PackageId ComponentName SubComponentTarget + | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget + | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget + | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget + + -- The target matching stuff only returns packages local to the project, + -- so these lookups should never fail, but if 'resolveTargets' is called + -- directly then of course it can. + | TargetProblemNoSuchPackage PackageId + | TargetProblemNoSuchComponent PackageId ComponentName + deriving (Eq, Show) + +-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts +-- for the extra unneeded info in the 'TargetsMap'. +-- +pruneInstallPlanToTargets :: TargetAction -> TargetsMap + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = + assert (Map.size targetsMap > 0) $ + ProjectPlanning.pruneInstallPlanToTargets + targetActionType + (Map.map (map fst) targetsMap) + elaboratedPlan + +-- | Utility used by repl and run to check if the targets spans multiple +-- components, since those commands do not support multiple components. +-- +distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents targetsMap = + Set.fromList [ (uid, cname) + | (uid, cts) <- Map.toList targetsMap + , (ComponentTarget cname _, _) <- cts ] + + ------------------------------------------------------------------------------ -- Displaying what we plan to do -- @@ -375,46 +619,70 @@ -- | Print a user-oriented presentation of the install plan, indicating what -- will be built. -- -printPlan :: Verbosity -> ProjectBuildContext -> IO () +printPlan :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO () printPlan verbosity - ProjectBuildContext { - elaboratedPlan, - pkgsBuildStatus, + ProjectBaseContext { buildSettings = BuildTimeSettings{buildSettingDryRun} } + ProjectBuildContext { + elaboratedPlanToExecute = elaboratedPlan, + elaboratedShared, + pkgsBuildStatus + } | null pkgs = notice verbosity "Up to date" - | verbosity >= verbose - = notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be built:") + | otherwise + = noticeNoWrap verbosity $ unlines $ + ("In order, the following " ++ wouldWill ++ " be built" ++ + ifNormal " (use -v for more details)" ++ ":") : map showPkgAndReason pkgs - | otherwise - = notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill - ++ " be built (use -v for more details):") - : map showPkg pkgs where - pkgs = linearizeInstallPlan elaboratedPlan + pkgs = InstallPlan.executionOrder elaboratedPlan + ifVerbose s | verbosity >= verbose = s + | otherwise = "" + + ifNormal s | verbosity >= verbose = "" + | otherwise = s + wouldWill | buildSettingDryRun = "would" | otherwise = "will" - showPkg pkg = display (packageId pkg) - showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage pkg _) = - display (packageId pkg) ++ - showTargets pkg ++ - showFlagAssignment (nonDefaultFlags pkg) ++ - showStanzas pkg ++ - let buildStatus = pkgsBuildStatus Map.! installedPackageId pkg in + showPkgAndReason (ReadyPackage elab) = + " - " ++ + (if verbosity >= deafening + then display (installedUnitId elab) + else display (packageId elab) + ) ++ + (case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) + ElabComponent comp -> + " (" ++ showComp elab comp ++ ")" + ) ++ + showFlagAssignment (nonDefaultFlags elab) ++ + showConfigureFlags elab ++ + let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in " (" ++ showBuildStatus buildStatus ++ ")" + showComp elab comp = + maybe "custom" display (compComponentName comp) ++ + if Map.null (elabInstantiatedWith elab) + then "" + else " with " ++ + intercalate ", " + -- TODO: Abbreviate the UnitIds + [ display k ++ "=" ++ display v + | (k,v) <- Map.toList (elabInstantiatedWith elab) ] + nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags pkg = pkgFlagAssignment pkg \\ pkgFlagDefaults pkg + nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab showStanzas pkg = concat $ [ " *test" @@ -422,21 +690,53 @@ ++ [ " *bench" | BenchStanzas `Set.member` pkgStanzasEnabled pkg ] - showTargets pkg - | null (pkgBuildTargets pkg) = "" + showTargets elab + | null (elabBuildTargets elab) = "" | otherwise - = " (" ++ unwords [ showComponentTarget pkg t | t <- pkgBuildTargets pkg ] + = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ] ++ ")" - -- TODO: [code cleanup] this should be a proper function in a proper place showFlagAssignment :: FlagAssignment -> String showFlagAssignment = concatMap ((' ' :) . showFlagValue) - showFlagValue (f, True) = '+' : showFlagName f - showFlagValue (f, False) = '-' : showFlagName f - showFlagName (PD.FlagName f) = f + showConfigureFlags elab = + let fullConfigureFlags + = setupHsConfigureFlags + (ReadyPackage elab) + elaboratedShared + verbosity + "$builddir" + -- | Given a default value @x@ for a flag, nub @Flag x@ + -- into @NoFlag@. This gives us a tidier command line + -- rendering. + nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a + nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag + nubFlag _ f = f + -- TODO: Closely logic from 'configureProfiling'. + tryExeProfiling = Setup.fromFlagOrDefault False + (configProf fullConfigureFlags) + tryLibProfiling = Setup.fromFlagOrDefault False + (Mon.mappend (configProf fullConfigureFlags) + (configProfExe fullConfigureFlags)) + partialConfigureFlags + = Mon.mempty { + configProf = + nubFlag False (configProf fullConfigureFlags), + configProfExe = + nubFlag tryExeProfiling (configProfExe fullConfigureFlags), + configProfLib = + nubFlag tryLibProfiling (configProfLib fullConfigureFlags) + -- Maybe there are more we can add + } + -- Not necessary to "escape" it, it's just for user output + in unwords . ("":) $ + commandShowOptions + (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + partialConfigureFlags + showBuildStatus status = case status of - BuildStatusPreExisting -> "already installed" + BuildStatusPreExisting -> "existing package" + BuildStatusInstalled -> "already installed" BuildStatusDownload {} -> "requires download & build" BuildStatusUnpack {} -> "requires build" BuildStatusRebuild _ rebuild -> case rebuild of @@ -446,48 +746,237 @@ BuildStatusBuild _ buildreason -> case buildreason of BuildReasonDepsRebuilt -> "dependency rebuilt" BuildReasonFilesChanged - (MonitoredFileChanged _) -> "files changed" - BuildReasonFilesChanged mreason -> showMonitorChangedReason mreason BuildReasonExtraTargets _ -> "additional components to build" BuildReasonEphemeralTargets -> "ephemeral targets" BuildStatusUpToDate {} -> "up to date" -- doesn't happen - showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file + showMonitorChangedReason (MonitoredFileChanged file) = "file " ++ file ++ " changed" showMonitorChangedReason (MonitoredValueChanged _) = "value changed" showMonitorChangedReason MonitorFirstRun = "first run" showMonitorChangedReason MonitorCorruptCache = "cannot read state cache" -linearizeInstallPlan :: ElaboratedInstallPlan -> [ElaboratedReadyPackage] -linearizeInstallPlan = - unfoldr next + +-- | If there are build failures then report them and throw an exception. +-- +dieOnBuildFailures :: Verbosity + -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +dieOnBuildFailures verbosity plan buildOutcomes + | null failures = return () + + | isSimpleCase = exitFailure + + | otherwise = do + -- For failures where we have a build log, print the log plus a header + sequence_ + [ do notice verbosity $ + '\n' : renderFailureDetail False pkg reason + ++ "\nBuild log ( " ++ logfile ++ " ):" + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) + <- failuresClassification + ] + + -- For all failures, print either a short summary (if we showed the + -- build log) or all details + die' verbosity $ unlines + [ case failureClassification of + ShowBuildSummaryAndLog reason _ + | verbosity > normal + -> renderFailureDetail mentionDepOf pkg reason + + | otherwise + -> renderFailureSummary mentionDepOf pkg reason + ++ ". See the build log above for details." + + ShowBuildSummaryOnly reason -> + renderFailureDetail mentionDepOf pkg reason + + | let mentionDepOf = verbosity <= normal + , (pkg, failureClassification) <- failuresClassification ] where - next plan = case InstallPlan.ready plan of - [] -> Nothing - (pkg:_) -> Just (pkg, plan') + failures = [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildOutcomes ] + + failuresClassification = + [ (pkg, classifyBuildFailure failure) + | (pkgid, failure) <- failures + , case buildFailureReason failure of + DependentFailed {} -> verbosity > normal + _ -> True + , InstallPlan.Configured pkg <- + maybeToList (InstallPlan.lookup plan pkgid) + ] + + classifyBuildFailure :: BuildFailure -> BuildFailurePresentation + classifyBuildFailure BuildFailure { + buildFailureReason = reason, + buildFailureLogFile = mlogfile + } = + maybe (ShowBuildSummaryOnly reason) + (ShowBuildSummaryAndLog reason) $ do + logfile <- mlogfile + e <- buildFailureException reason + ExitFailure 1 <- fromException e + return logfile + + -- Special case: we don't want to report anything complicated in the case + -- of just doing build on the current package, since it's clear from + -- context which package failed. + -- + -- We generalise this rule as follows: + -- - if only one failure occurs, and it is in a single root package (ie a + -- package with nothing else depending on it) + -- - and that failure is of a kind that always reports enough detail + -- itself (e.g. ghc reporting errors on stdout) + -- - then we do not report additional error detail or context. + -- + isSimpleCase + | [(pkgid, failure)] <- failures + , [pkg] <- rootpkgs + , installedUnitId pkg == pkgid + , isFailureSelfExplanatory (buildFailureReason failure) + = True + | otherwise + = False + + -- NB: if the Setup script segfaulted or was interrupted, + -- we should give more detailed information. So only + -- assume that exit code 1 is "pedestrian failure." + isFailureSelfExplanatory (BuildFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory (ConfigureFailed e) + | Just (ExitFailure 1) <- fromException e = True + + isFailureSelfExplanatory _ = False + + rootpkgs = + [ pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan + , hasNoDependents pkg ] + + ultimateDeps pkgid = + filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (InstallPlan.reverseDependencyClosure plan [pkgid]) + + hasNoDependents :: HasUnitId pkg => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + + renderFailureDetail mentionDepOf pkg reason = + renderFailureSummary mentionDepOf pkg reason ++ "." + ++ renderFailureExtraDetail reason + ++ maybe "" showException (buildFailureException reason) + + renderFailureSummary mentionDepOf pkg reason = + case reason of + DownloadFailed _ -> "Failed to download " ++ pkgstr + UnpackFailed _ -> "Failed to unpack " ++ pkgstr + ConfigureFailed _ -> "Failed to build " ++ pkgstr + BuildFailed _ -> "Failed to build " ++ pkgstr + ReplFailed _ -> "repl failed for " ++ pkgstr + HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr + TestsFailed _ -> "Tests failed for " ++ pkgstr + InstallFailed _ -> "Failed to build " ++ pkgstr + DependentFailed depid + -> "Failed to build " ++ display (packageId pkg) + ++ " because it depends on " ++ display depid + ++ " which itself failed to build" + where + pkgstr = elabConfiguredName verbosity pkg + ++ if mentionDepOf + then renderDependencyOf (installedUnitId pkg) + else "" + + renderFailureExtraDetail reason = + case reason of + ConfigureFailed _ -> " The failure occurred during the configure step." + InstallFailed _ -> " The failure occurred during the final install step." + _ -> "" + + renderDependencyOf pkgid = + case ultimateDeps pkgid of + [] -> "" + (p1:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")" + (p1:p2:[]) -> " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")" + (p1:p2:_) -> " (which is required by " ++ elabPlanPackageName verbosity p1 + ++ ", " ++ elabPlanPackageName verbosity p2 + ++ " and others)" + + showException e = case fromException e of + Just (ExitFailure 1) -> "" + +#ifdef MIN_VERSION_unix + -- Note [Positive "signal" exit code] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- What's the business with the test for negative and positive + -- signal values? The API for process specifies that if the + -- process died due to a signal, it returns a *negative* exit + -- code. So that's the negative test. + -- + -- What about the positive test? Well, when we find out that + -- a process died due to a signal, we ourselves exit with that + -- exit code. However, we don't "kill ourselves" with the + -- signal; we just exit with the same code as the signal: thus + -- the caller sees a *positive* exit code. So that's what + -- happens when we get a positive exit code. + Just (ExitFailure n) + | -n == fromIntegral sigSEGV -> + " The build process segfaulted (i.e. SIGSEGV)." + + | n == fromIntegral sigSEGV -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)." + + | -n == fromIntegral sigKILL -> + " The build process was killed (i.e. SIGKILL). " ++ explanation + + | n == fromIntegral sigKILL -> + " The build process terminated with exit code " ++ show n + ++ " which may be because some part of it was killed " + ++ "(i.e. SIGKILL). " ++ explanation where - ipkgid = installedPackageId pkg - ipkg = Installed.emptyInstalledPackageInfo { - Installed.sourcePackageId = packageId pkg, - Installed.installedUnitId = ipkgid - } - plan' = InstallPlan.completed ipkgid (Just ipkg) - (BuildOk DocsNotTried TestsNotTried) - (InstallPlan.processing [pkg] plan) - --TODO: [code cleanup] This is a bit of a hack, pretending that each package is installed - -- could we use InstallPlan.topologicalOrder? + explanation = "The typical reason for this is that there is not " + ++ "enough memory available (e.g. the OS killed a process " + ++ "using lots of memory)." +#endif + Just (ExitFailure n) -> + " The build process terminated with exit code " ++ show n + _ -> " The exception was:\n " +#if MIN_VERSION_base(4,8,0) + ++ displayException e +#else + ++ show e +#endif -reportBuildFailures :: ElaboratedInstallPlan -> IO () -reportBuildFailures plan = + buildFailureException reason = + case reason of + DownloadFailed e -> Just e + UnpackFailed e -> Just e + ConfigureFailed e -> Just e + BuildFailed e -> Just e + ReplFailed e -> Just e + HaddocksFailed e -> Just e + TestsFailed e -> Just e + InstallFailed e -> Just e + DependentFailed _ -> Nothing - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of - [] -> return () - _failed -> exitFailure - --TODO: [required eventually] see the old printBuildFailures for an example - -- of the kind of things we could report, but we want to handle the special - -- case of the current package better, since if you do "cabal build" then - -- you don't need a lot of context to explain where the ghc error message - -- comes from, and indeed extra noise would just be annoying. +data BuildFailurePresentation = + ShowBuildSummaryOnly BuildFailureReason + | ShowBuildSummaryAndLog BuildFailureReason FilePath + + +cmdCommonHelpTextNewBuildBeta :: String +cmdCommonHelpTextNewBuildBeta = + "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -2,31 +2,65 @@ DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} --- | An experimental new UI for cabal for working with multiple packages ------------------------------------------------------------------------------ module Distribution.Client.ProjectPlanOutput ( + -- * Plan output writePlanExternalRepresentation, + + -- * Project status + -- | Several outputs rely on having a general overview of + PostBuildProjectStatus(..), + updatePostBuildProjectStatus, + writePlanGhcEnvironment, ) where import Distribution.Client.ProjectPlanning.Types - ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..) - , ElaboratedSharedConfig(..) ) +import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout +import Distribution.Client.Types (confInstId) +import Distribution.Client.PackageHash (showHashValue) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J -import qualified Distribution.Client.ComponentDeps as ComponentDeps +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps + import Distribution.Package +import Distribution.System +import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.PackageDescription as PD +import Distribution.Compiler (CompilerFlavor(GHC)) +import Distribution.Simple.Compiler + ( PackageDBStack, PackageDB(..) + , compilerVersion, compilerFlavor, showCompilerId ) +import Distribution.Simple.GHC + ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) + , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile + , writeGhcEnvironmentFile ) import Distribution.Text +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (Graph, Node) +import qualified Distribution.Compat.Binary as Binary import Distribution.Simple.Utils +import Distribution.Verbosity import qualified Paths_cabal_install as Our (version) +import Data.Maybe (maybeToList, fromMaybe) import Data.Monoid +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB +import System.FilePath +import System.IO + +----------------------------------------------------------------------------- +-- Writing plan.json files +-- + -- | Write out a representation of the elaborated install plan. -- -- This is for the benefit of debugging and external tools like editors. @@ -40,61 +74,736 @@ writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $ BB.toLazyByteString . J.encodeToBuilder - $ encodePlanAsJson elaboratedInstallPlan elaboratedSharedConfig + $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig -- | Renders a subset of the elaborated install plan in a semi-stable JSON -- format. -- -encodePlanAsJson :: ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value -encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig = +encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value +encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = --TODO: [nice to have] include all of the sharedPackageConfig and all of -- the parts of the elaboratedInstallPlan J.object [ "cabal-version" J..= jdisplay Our.version , "cabal-lib-version" J..= jdisplay cabalVersion - , "install-plan" J..= jsonIPlan + , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler) + elaboratedSharedConfig + , "os" J..= jdisplay os + , "arch" J..= jdisplay arch + , "install-plan" J..= installPlanToJ elaboratedInstallPlan ] where - jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan) + Platform arch os = pkgConfigPlatform elaboratedSharedConfig - -- ipi :: InstalledPackageInfo - toJ (InstallPlan.PreExisting ipi) = - -- installed packages currently lack configuration information - -- such as their flag settings or non-lib components. + installPlanToJ :: ElaboratedInstallPlan -> [J.Value] + installPlanToJ = map planPackageToJ . InstallPlan.toList + + planPackageToJ :: ElaboratedPlanPackage -> J.Value + planPackageToJ pkg = + case pkg of + InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi + InstallPlan.Configured elab -> elaboratedPackageToJ False elab + InstallPlan.Installed elab -> elaboratedPackageToJ True elab + -- Note that the plan.json currently only uses the elaborated plan, + -- not the improved plan. So we will not get the Installed state for + -- that case, but the code supports it in case we want to use this + -- later in some use case where we want the status of the build. + + installedPackageInfoToJ :: InstalledPackageInfo -> J.Value + installedPackageInfoToJ ipi = + -- Pre-existing packages lack configuration information such as their flag + -- settings or non-lib components. We only get pre-existing packages for + -- the global/core packages however, so this isn't generally a problem. + -- So these packages are never local to the project. -- - -- TODO: how to find out whether package is "local"? J.object [ "type" J..= J.String "pre-existing" - , "id" J..= jdisplay (installedUnitId ipi) - , "components" J..= J.object - [ "lib" J..= J.object [ "depends" J..= map jdisplay (installedDepends ipi) ] ] + , "id" J..= (jdisplay . installedUnitId) ipi + , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi + , "depends" J..= map jdisplay (installedDepends ipi) ] - -- ecp :: ElaboratedConfiguredPackage - toJ (InstallPlan.Configured ecp) = - J.object - [ "type" J..= J.String "configured" - , "id" J..= (jdisplay . installedUnitId) ecp - , "components" J..= components - , "flags" J..= J.object [ fn J..= v - | (PD.FlagName fn,v) <- pkgFlagAssignment ecp ] - ] - where - components = J.object - [ comp2str c J..= J.object - [ "depends" J..= map (jdisplay . installedUnitId) v ] - | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ] + elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value + elaboratedPackageToJ isInstalled elab = + J.object $ + [ "type" J..= J.String (if isInstalled then "installed" + else "configured") + , "id" J..= (jdisplay . installedUnitId) elab + , "pkg-name" J..= (jdisplay . pkgName . packageId) elab + , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab + , "flags" J..= J.object [ PD.unFlagName fn J..= v + | (fn,v) <- elabFlagAssignment elab ] + , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + ] ++ + [ "pkg-src-sha256" J..= J.String (showHashValue hash) + | Just hash <- [elabPkgSourceHash elab] ] ++ + (case elabBuildStyle elab of + BuildInplaceOnly -> + ["dist-dir" J..= J.String dist_dir] + BuildAndInstall -> + -- TODO: install dirs? + [] + ) ++ + case elabPkgOrComp elab of + ElabPackage pkg -> + let components = J.object $ + [ comp2str c J..= (J.object $ + [ "depends" J..= map (jdisplay . confInstId) ldeps + , "exe-depends" J..= map (jdisplay . confInstId) edeps ] ++ + bin_file c) + | (c,(ldeps,edeps)) + <- ComponentDeps.toList $ + ComponentDeps.zip (pkgLibDependencies pkg) + (pkgExeDependencies pkg) ] + in ["components" J..= components] + ElabComponent comp -> + ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) + ,"component-name" J..= J.String (comp2str (compSolverName comp)) + ] ++ + bin_file (compSolverName comp) + where + dist_dir = distBuildDirectory distDirLayout + (elabDistDirParams elaboratedSharedConfig elab) - toJ _ = error "encodePlanToJson: only expecting PreExisting and Configured" + bin_file c = case c of + ComponentDeps.ComponentExe s -> bin_file' s + ComponentDeps.ComponentTest s -> bin_file' s + ComponentDeps.ComponentBench s -> bin_file' s + _ -> [] + bin_file' s = + ["bin-file" J..= J.String bin] + where + bin = if elabBuildStyle elab == BuildInplaceOnly + then dist_dir "build" display s display s + else InstallDirs.bindir (elabInstallDirs elab) display s -- TODO: maybe move this helper to "ComponentDeps" module? -- Or maybe define a 'Text' instance? + comp2str :: ComponentDeps.Component -> String comp2str c = case c of ComponentDeps.ComponentLib -> "lib" - ComponentDeps.ComponentExe s -> "exe:" <> s - ComponentDeps.ComponentTest s -> "test:" <> s - ComponentDeps.ComponentBench s -> "bench:" <> s + ComponentDeps.ComponentSubLib s -> "lib:" <> display s + ComponentDeps.ComponentFLib s -> "flib:" <> display s + ComponentDeps.ComponentExe s -> "exe:" <> display s + ComponentDeps.ComponentTest s -> "test:" <> display s + ComponentDeps.ComponentBench s -> "bench:" <> display s ComponentDeps.ComponentSetup -> "setup" + style2str :: Bool -> BuildStyle -> String + style2str True _ = "local" + style2str False BuildInplaceOnly = "inplace" + style2str False BuildAndInstall = "global" + jdisplay :: Text a => a -> J.Value jdisplay = J.String . display + + +----------------------------------------------------------------------------- +-- Project status +-- + +-- So, what is the status of a project after a build? That is, how do the +-- inputs (package source files etc) compare to the output artefacts (build +-- libs, exes etc)? Do the outputs reflect the current values of the inputs +-- or are outputs out of date or invalid? +-- +-- First of all, what do we mean by out-of-date and what do we mean by +-- invalid? We think of the build system as a morally pure function that +-- computes the output artefacts given input values. We say an output artefact +-- is out of date when its value is not the value that would be computed by a +-- build given the current values of the inputs. An output artefact can be +-- out-of-date but still be perfectly usable; it simply correspond to a +-- previous state of the inputs. +-- +-- On the other hand there are cases where output artefacts cannot safely be +-- used. For example libraries and dynamically linked executables cannot be +-- used when the libs they depend on change without them being recompiled +-- themselves. Whether an artefact is still usable depends on what it is, e.g. +-- dynamically linked vs statically linked and on how it gets updated (e.g. +-- only atomically on success or if failure can leave invalid states). We need +-- a definition (or two) that is independent of the kind of artefact and can +-- be computed just in terms of changes in package graphs, but are still +-- useful for determining when particular kinds of artefacts are invalid. +-- +-- Note that when we talk about packages in this context we just mean nodes +-- in the elaborated install plan, which can be components or packages. +-- +-- There's obviously a close connection between packages being out of date and +-- their output artefacts being unusable: most of the time if a package +-- remains out of date at the end of a build then some of its output artefacts +-- will be unusable. That is true most of the time because a build will have +-- attempted to build one of the out-of-date package's dependencies. If the +-- build of the dependency succeeded then it changed output artefacts (like +-- libs) and if it failed then it may have failed after already changing +-- things (think failure after updating some but not all .hi files). +-- +-- There are a few reasons we may end up with still-usable output artefacts +-- for a package even when it remains out of date at the end of a build. +-- Firstly if executing a plan fails then packages can be skipped, and thus we +-- may have packages where all their dependencies were skipped. Secondly we +-- have artefacts like statically linked executables which are not affected by +-- libs they depend on being recompiled. Furthermore, packages can be out of +-- date due to changes in build tools or Setup.hs scripts they depend on, but +-- again libraries or executables in those out-of-date packages remain usable. +-- +-- So we have two useful definitions of invalid. Both are useful, for +-- different purposes, so we will compute both. The first corresponds to the +-- invalid libraries and dynamic executables. We say a package is invalid by +-- changed deps if any of the packages it depends on (via library dep edges) +-- were rebuilt (successfully or unsuccessfully). The second definition +-- corresponds to invalid static executables. We say a package is invalid by +-- a failed build simply if the package was built but unsuccessfully. +-- +-- So how do we find out what packages are out of date or invalid? +-- +-- Obviously we know something for all the packages that were part of the plan +-- that was executed, but that is just a subset since we prune the plan down +-- to the targets and their dependencies. +-- +-- Recall the steps we go though: +-- +-- + starting with the initial improved plan (this is the full project); +-- +-- + prune the plan to the user's build targets; +-- +-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap +-- covering the pruned subset of the original plan; +-- +-- + execute the plan giving us BuildOutcomes which tell us success/failure +-- for each package. +-- +-- So given that the BuildStatusMap and BuildOutcomes do not cover everything +-- in the original plan, what can they tell us about the original plan? +-- +-- The BuildStatusMap tells us directly that some packages are up to date and +-- others out of date (but only for the pruned subset). But we know that +-- everything that is a reverse dependency of an out-of-date package is itself +-- out-of-date (whether or not it is in the pruned subset). Of course after +-- a build the BuildOutcomes may tell us that some of those out-of-date +-- packages are now up to date (ie a successful build outcome). +-- +-- The difference is packages that are reverse dependencies of out-of-date +-- packages but are not brought up-to-date by the build (i.e. did not have +-- successful outcomes, either because they failed or were not in the pruned +-- subset to be built). We also know which packages were rebuilt, so we can +-- use this to find the now-invalid packages. +-- +-- Note that there are still packages for which we cannot discover full status +-- information. There may be packages outside of the pruned plan that do not +-- depend on packages within the pruned plan that were discovered to be +-- out-of-date. For these packages we do not know if their build artefacts +-- are out-of-date or not. We do know however that they are not invalid, as +-- that's not possible given our definition of invalid. Intuitively it is +-- because we have not disturbed anything that these packages depend on, e.g. +-- we've not rebuilt any libs they depend on. Recall that our widest +-- definition of invalid was only concerned about dependencies on libraries +-- (to cover problems like shared libs or GHC seeing inconsistent .hi files). +-- +-- So our algorithm for out-of-date packages is relatively simple: take the +-- reverse dependency closure in the original improved plan (pre-pruning) of +-- the out-of-date packages (as determined by the BuildStatusMap from the dry +-- run). That gives a set of packages that were definitely out of date after +-- the dry run. Now we remove from this set the packages that the +-- BuildOutcomes tells us are now up-to-date after the build. The remaining +-- set is the out-of-date packages. +-- +-- As for packages that are invalid by changed deps, we start with the plan +-- dependency graph but keep only those edges that point to libraries (so +-- ignoring deps on exes and setup scripts). We take the packages for which a +-- build was attempted (successfully or unsuccessfully, but not counting +-- knock-on failures) and take the reverse dependency closure. We delete from +-- this set all the packages that were built successfully. Note that we do not +-- need to intersect with the out-of-date packages since this follows +-- automatically: all rev deps of packages we attempted to build must have +-- been out of date at the start of the build, and if they were not built +-- successfully then they're still out of date -- meeting our definition of +-- invalid. + + +type PackageIdSet = Set UnitId +type PackagesUpToDate = PackageIdSet + +data PostBuildProjectStatus = PostBuildProjectStatus { + + -- | Packages that are known to be up to date. These were found to be + -- up to date before the build, or they have a successful build outcome + -- afterwards. + -- + -- This does not include any packages outside of the subset of the plan + -- that was executed because we did not check those and so don't know + -- for sure that they're still up to date. + -- + packagesDefinitelyUpToDate :: PackageIdSet, + + -- | Packages that are probably still up to date (and at least not + -- known to be out of date, and certainly not invalid). This includes + -- 'packagesDefinitelyUpToDate' plus packages that were up to date + -- previously and are outside of the subset of the plan that was + -- executed. It excludes 'packagesOutOfDate'. + -- + packagesProbablyUpToDate :: PackageIdSet, + + -- | Packages that are known to be out of date. These are packages + -- that were determined to be out of date before the build, and they + -- do not have a successful build outcome afterwards. + -- + -- Note that this can sometimes include packages outside of the subset + -- of the plan that was executed. For example suppose package A and B + -- depend on C, and A is the target so only A and C are in the subset + -- to be built. Now suppose C is found to have changed, then both A + -- and B are out-of-date before the build and since B is outside the + -- subset to be built then it will remain out of date. + -- + -- Note also that this is /not/ the inverse of + -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'. + -- There are packages where we have no information (ones that were not + -- in the subset of the plan that was executed). + -- + packagesOutOfDate :: PackageIdSet, + + -- | Packages that depend on libraries that have changed during the + -- build (either build success or failure). + -- + -- This corresponds to the fact that libraries and dynamic executables + -- are invalid once any of the libs they depend on change. + -- + -- This does include packages that themselves failed (i.e. it is a + -- superset of 'packagesInvalidByFailedBuild'). It does not include + -- changes in dependencies on executables (i.e. build tools). + -- + packagesInvalidByChangedLibDeps :: PackageIdSet, + + -- | Packages that themselves failed during the build (i.e. them + -- directly not a dep). + -- + -- This corresponds to the fact that static executables are invalid + -- in unlucky circumstances such as linking failing half way though, + -- or data file generation failing. + -- + -- This is a subset of 'packagesInvalidByChangedLibDeps'. + -- + packagesInvalidByFailedBuild :: PackageIdSet, + + -- | A subset of the plan graph, including only dependency-on-library + -- edges. That is, dependencies /on/ libraries, not dependencies /of/ + -- libraries. This tells us all the libraries that packages link to. + -- + -- This is here as a convenience, as strictly speaking it's not status + -- as it's just a function of the original 'ElaboratedInstallPlan'. + -- + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage), + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are part of the + -- project locally (i.e. with a local source dir). + -- + packagesBuildLocal :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' with any of the other + -- 'PackageIdSet's to select only packages that are being built + -- in-place within the project (i.e. not destined for the store). + -- + packagesBuildInplace :: PackageIdSet, + + -- | As a convenience for 'Set.intersection' or 'Set.difference' with + -- any of the other 'PackageIdSet's to select only packages that were + -- pre-installed or already in the store prior to the build. + -- + packagesAlreadyInStore :: PackageIdSet + } + +-- | Work out which packages are out of date or invalid after a build. +-- +postBuildProjectStatus :: ElaboratedInstallPlan + -> PackagesUpToDate + -> BuildStatusMap + -> BuildOutcomes + -> PostBuildProjectStatus +postBuildProjectStatus plan previousPackagesUpToDate + pkgBuildStatus buildOutcomes = + PostBuildProjectStatus { + packagesDefinitelyUpToDate, + packagesProbablyUpToDate, + packagesOutOfDate, + packagesInvalidByChangedLibDeps, + packagesInvalidByFailedBuild, + -- convenience stuff + packagesLibDepGraph, + packagesBuildLocal, + packagesBuildInplace, + packagesAlreadyInStore + } + where + packagesDefinitelyUpToDate = + packagesUpToDatePreBuild + `Set.union` + packagesSuccessfulPostBuild + + packagesProbablyUpToDate = + packagesDefinitelyUpToDate + `Set.union` + (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild) + + packagesOutOfDate = + packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByChangedLibDeps = + packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild + + packagesInvalidByFailedBuild = + packagesFailurePostBuild + + -- Note: if any of the intermediate values below turn out to be useful in + -- their own right then we can simply promote them to the result record + + -- The previous set of up-to-date packages will contain bogus package ids + -- when the solver plan or config contributing to the hash changes. + -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' = + Set.intersection + previousPackagesUpToDate + (InstallPlan.keysSet plan) + + packagesUpToDatePreBuild = + Set.filter + (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /up to date/. + (InstallPlan.keysSet plan) + + packagesOutOfDatePreBuild = + Set.fromList . map installedUnitId $ + InstallPlan.reverseDependencyClosure plan + [ ipkgid + | pkg <- InstallPlan.toList plan + , let ipkgid = installedUnitId pkg + , lookupBuildStatusRequiresBuild False ipkgid + -- For packages not in the plan subset we did the dry-run on we don't + -- know anything about their status, so not known to be /out of date/. + ] + + packagesSuccessfulPostBuild = + Set.fromList + [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ] + + -- direct failures, not failures due to deps + packagesFailurePostBuild = + Set.fromList + [ ikgid + | (ikgid, Left failure) <- Map.toList buildOutcomes + , case buildFailureReason failure of + DependentFailed _ -> False + _ -> True + ] + + -- Packages that have a library dependency on a package for which a build + -- was attempted + packagesDepOnChangedLib = + Set.fromList . map Graph.nodeKey $ + fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ + Graph.revClosure packagesLibDepGraph + ( Map.keys + . Map.filter (uncurry buildAttempted) + $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes + ) + + -- The plan graph but only counting dependency-on-library edges + packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph = + Graph.fromDistinctList + [ Graph.N pkg (installedUnitId pkg) libdeps + | pkg <- InstallPlan.toList plan + , let libdeps = case pkg of + InstallPlan.PreExisting ipkg -> installedDepends ipkg + InstallPlan.Configured srcpkg -> elabLibDeps srcpkg + InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + ] + elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies + + -- Was a build was attempted for this package? + -- If it doesn't have both a build status and outcome then the answer is no. + buildAttempted :: BuildStatus -> BuildOutcome -> Bool + -- And not if it didn't need rebuilding in the first place. + buildAttempted buildStatus _buildOutcome + | not (buildStatusRequiresBuild buildStatus) + = False + + -- And not if it was skipped due to a dep failing first. + buildAttempted _ (Left BuildFailure {buildFailureReason}) + | DependentFailed _ <- buildFailureReason + = False + + -- Otherwise, succeeded or failed, yes the build was tried. + buildAttempted _ (Left BuildFailure {}) = True + buildAttempted _ (Right _) = True + + lookupBuildStatusRequiresBuild def ipkgid = + case Map.lookup ipkgid pkgBuildStatus of + Nothing -> def -- Not in the plan subset we did the dry-run on + Just buildStatus -> buildStatusRequiresBuild buildStatus + + packagesBuildLocal = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg + + packagesBuildInplace = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> False + InstallPlan.Installed _ -> False + InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg + == BuildInplaceOnly + + packagesAlreadyInStore = + selectPlanPackageIdSet $ \pkg -> + case pkg of + InstallPlan.PreExisting _ -> True + InstallPlan.Installed _ -> True + InstallPlan.Configured _ -> False + + selectPlanPackageIdSet p = Map.keysSet + . Map.filter p + $ InstallPlan.toMap plan + + + +updatePostBuildProjectStatus :: Verbosity + -> DistDirLayout + -> ElaboratedInstallPlan + -> BuildStatusMap + -> BuildOutcomes + -> IO PostBuildProjectStatus +updatePostBuildProjectStatus verbosity distDirLayout + elaboratedInstallPlan + pkgsBuildStatus buildOutcomes = do + + -- Read the previous up-to-date set, update it and write it back + previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout + let currentBuildStatus@PostBuildProjectStatus{..} + = postBuildProjectStatus + elaboratedInstallPlan + previousUpToDate + pkgsBuildStatus + buildOutcomes + let currentUpToDate = packagesProbablyUpToDate + writePackagesUpToDateCacheFile distDirLayout currentUpToDate + + -- Report various possibly interesting things + -- We additionally intersect with the packagesBuildInplace so that + -- we don't show huge numbers of boring packages from the store. + debugNoWrap verbosity $ + "packages definitely up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages previously probably up to date: " + ++ displayPackageIdSet (previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages now probably up to date: " + ++ displayPackageIdSet (packagesProbablyUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages newly up to date: " + ++ displayPackageIdSet (packagesDefinitelyUpToDate + `Set.difference` previousUpToDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages out to date: " + ++ displayPackageIdSet (packagesOutOfDate + `Set.intersection` packagesBuildInplace) + + debugNoWrap verbosity $ + "packages invalid due to dep change: " + ++ displayPackageIdSet packagesInvalidByChangedLibDeps + + debugNoWrap verbosity $ + "packages invalid due to build failure: " + ++ displayPackageIdSet packagesInvalidByFailedBuild + + return currentBuildStatus + where + displayPackageIdSet = intercalate ", " . map display . Set.toList + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +-- +readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate +readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} = + handleDoesNotExist Set.empty $ + handleDecodeFailure $ + withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> + Binary.decodeOrFailIO =<< BS.hGetContents hnd + where + handleDecodeFailure = fmap (either (const Set.empty) id) + +-- | Helper for writing the package up-to-date cache file. +-- +-- This determines the type and format of the binary cache file. +-- +writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () +writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = + writeFileAtomic (distProjectCacheFile "up-to-date") $ + Binary.encode upToDate + +-- Writing .ghc.environment files +-- + +writePlanGhcEnvironment :: DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO () +writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory} + elaboratedInstallPlan + ElaboratedSharedConfig { + pkgConfigCompiler = compiler, + pkgConfigPlatform = platform + } + postBuildStatus + | compilerFlavor compiler == GHC + , supportsPkgEnvFiles (getImplInfo compiler) + --TODO: check ghcjs compat + --TODO: This feature is temporarily disabled due to #4010 + , False + = writeGhcEnvironmentFile + distProjectRootDirectory + platform (compilerVersion compiler) + (renderGhcEnviromentFile distProjectRootDirectory + elaboratedInstallPlan + postBuildStatus) + --TODO: [required eventually] support for writing user-wide package + -- environments, e.g. like a global project, but we would not put the + -- env file in the home dir, rather it lives under ~/.ghc/ + +writePlanGhcEnvironment _ _ _ _ = return () + +renderGhcEnviromentFile :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +renderGhcEnviromentFile projectRootDir elaboratedInstallPlan + postBuildStatus = + headerComment + : simpleGhcEnvironmentFile packageDBs unitIds + where + headerComment = + GhcEnvFileComment + $ "This is a GHC environment file written by cabal. This means you can\n" + ++ "run ghc or ghci and get the environment of the project as a whole.\n" + ++ "But you still need to use cabal repl $target to get the environment\n" + ++ "of specific components (libs, exes, tests etc) because each one can\n" + ++ "have its own source dirs, cpp flags etc.\n\n" + unitIds = selectGhcEnviromentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnviromentFilePackageDbs elaboratedInstallPlan + + +-- We're producing an environment for users to use in ghci, so of course +-- that means libraries only (can't put exes into the ghc package env!). +-- The library environment should be /consistent/ with the environment +-- that each of the packages in the project use (ie same lib versions). +-- So that means all the normal library dependencies of all the things +-- in the project (including deps of exes that are local to the project). +-- We do not however want to include the dependencies of Setup.hs scripts, +-- since these are generally uninteresting but also they need not in +-- general be consistent with the library versions that packages local to +-- the project use (recall that Setup.hs script's deps can be picked +-- independently of other packages in the project). +-- +-- So, our strategy is as follows: +-- +-- produce a dependency graph of all the packages in the install plan, +-- but only consider normal library deps as edges in the graph. Thus we +-- exclude the dependencies on Setup.hs scripts (in the case of +-- per-component granularity) or of Setup.hs scripts (in the case of +-- per-package granularity). Then take a dependency closure, using as +-- roots all the packages/components local to the project. This will +-- exclude Setup scripts and their dependencies. +-- +-- Note: this algorithm will have to be adapted if/when the install plan +-- is extended to cover multiple compilers at once, and may also have to +-- change if we start to treat unshared deps of test suites in a similar +-- way to how we treat Setup.hs script deps (ie being able to pick them +-- independently). +-- +-- Since we had to use all the local packages, including exes, (as roots +-- to find the libs) then those exes still end up in our list so we have +-- to filter them out at the end. +-- +selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} = + case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of + Nothing -> error "renderGhcEnviromentFile: broken dep closure" + Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes + , hasUpToDateLib pkg ] + where + hasUpToDateLib planpkg = case planpkg of + -- A pre-existing global lib + InstallPlan.PreExisting _ -> True + + -- A package in the store. Check it's a lib. + InstallPlan.Installed pkg -> elabRequiresRegistration pkg + + -- A package we were installing this time, either destined for the store + -- or just locally. Check it's a lib and that it is probably up to date. + InstallPlan.Configured pkg -> + elabRequiresRegistration pkg + && installedUnitId pkg `Set.member` packagesProbablyUpToDate + + +selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnviromentFilePackageDbs elaboratedInstallPlan = + -- If we have any inplace packages then their package db stack is the + -- one we should use since it'll include the store + the local db but + -- it's certainly possible to have no local inplace packages + -- e.g. just "extra" packages coming from the store. + case (inplacePackages, sourcePackages) of + ([], pkgs) -> checkSamePackageDBs pkgs + (pkgs, _) -> checkSamePackageDBs pkgs + where + checkSamePackageDBs pkgs = + case ordNub (map elabBuildPackageDBStack pkgs) of + [packageDbs] -> packageDbs + [] -> [] + _ -> error $ "renderGhcEnviromentFile: packages with " + ++ "different package db stacks" + -- This should not happen at the moment but will happen as soon + -- as we support projects where we build packages with different + -- compilers, at which point we have to consider how to adapt + -- this feature, e.g. write out multiple env files, one for each + -- compiler / project profile. + + inplacePackages = + [ srcpkg + | srcpkg <- sourcePackages + , elabBuildStyle srcpkg == BuildInplaceOnly ] + sourcePackages = + [ srcpkg + | pkg <- InstallPlan.toList elaboratedInstallPlan + , srcpkg <- maybeToList $ case pkg of + InstallPlan.Configured srcpkg -> Just srcpkg + InstallPlan.Installed srcpkg -> Just srcpkg + InstallPlan.PreExisting _ -> Nothing + ] + +relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack +relativePackageDBPaths relroot = map (relativePackageDBPath relroot) + +relativePackageDBPath :: FilePath -> PackageDB -> PackageDB +relativePackageDBPath relroot pkgdb = + case pkgdb of + GlobalPackageDB -> GlobalPackageDB + UserPackageDB -> UserPackageDB + SpecificPackageDB path -> SpecificPackageDB relpath + where relpath = makeRelative relroot path diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -1,2283 +1,3356 @@ {-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} - --- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - --TODO: [code cleanup] these types should live with execution, not with - -- plan definition. Need to better separate InstallPlan definition. - GenericBuildResult(..), - BuildResult, - BuildSuccess(..), - BuildFailure(..), - DocsResult(..), - TestsResult(..), - - -- * Producing the elaborated install plan - rebuildInstallPlan, - - -- * Build targets - PackageTarget(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - - -- * Selecting a plan subset - pruneInstallPlanToTargets, - - -- * Utils required for building - pkgHasEphemeralBuildTargets, - pkgBuildTargetWholeComponents, - - -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - - packageHashInputs, - - -- TODO: [code cleanup] utils that should live in some shared place? - createPackageDBIfMissing - ) where - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.ComponentDeps as CD -import Distribution.Client.ComponentDeps (ComponentDeps) -import qualified Distribution.Client.IndexUtils as IndexUtils -import qualified Distribution.Client.PackageIndex as SourcePackageIndex -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import qualified Hackage.Security.Client as Sec -import Distribution.Client.PkgConfigDb -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList - -import Distribution.Package hiding - (InstalledPackageId, installedPackageId) -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Compiler hiding (Flag) -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) -import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo (ComponentName(..)) -import qualified Distribution.Simple.Register as Cabal -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Simple.BuildTarget as Cabal - -import Distribution.Simple.Utils hiding (matchFileGlob) -import Distribution.Version -import Distribution.Verbosity -import Distribution.Text - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Graph as Graph -import qualified Data.Tree as Tree -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad -import Control.Monad.State as State -import Control.Exception -import Data.List -import Data.Maybe -import Data.Either -import Data.Monoid -import Data.Function -import System.FilePath -import System.Directory (doesDirectoryExist) - - ------------------------------------------------------------------------------- --- * Elaborated install plan ------------------------------------------------------------------------------- - --- "Elaborated" -- worked out with great care and nicety of detail; --- executed with great minuteness: elaborate preparations; --- elaborate care. --- --- So here's the idea: --- --- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc --- all passed in as separate args and which are then further selected, --- transformed etc during the execution of the build. Instead we construct --- an elaborated install plan that includes everything we will need, and then --- during the execution of the plan we do as little transformation of this --- info as possible. --- --- So we're trying to split the work into two phases: construction of the --- elaborated install plan (which as far as possible should be pure) and --- then simple execution of that plan without any smarts, just doing what the --- plan says to do. --- --- So that means we need a representation of this fully elaborated install --- plan. The representation consists of two parts: --- --- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a --- representation of source packages that includes a lot more detail about --- that package's individual configuration --- --- * A 'ElaboratedSharedConfig'. Some package configuration is the same for --- every package in a plan. Rather than duplicate that info every entry in --- the 'GenericInstallPlan' we keep that separately. --- --- The division between the shared and per-package config is /not set in stone --- for all time/. For example if we wanted to generalise the install plan to --- describe a situation where we want to build some packages with GHC and some --- with GHCJS then the platform and compiler would no longer be shared between --- all packages but would have to be per-package (probably with some sanity --- condition on the graph structure). --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- type ElaboratedInstallPlan = ... --- type ElaboratedPlanPackage = ... --- data ElaboratedSharedConfig = ... --- data ElaboratedConfiguredPackage = ... --- data BuildStyle = - - -sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> Bool -sanityCheckElaboratedConfiguredPackage sharedConfig - pkg@ElaboratedConfiguredPackage{..} = - - pkgStanzasEnabled `Set.isSubsetOf` pkgStanzasAvailable - - -- the stanzas explicitly enabled should be available and enabled - && Map.keysSet (Map.filter id pkgStanzasRequested) - `Set.isSubsetOf` pkgStanzasEnabled - - -- the stanzas explicitly disabled should not be available - && Set.null (Map.keysSet (Map.filter not pkgStanzasRequested) - `Set.intersection` pkgStanzasAvailable) - - && (pkgBuildStyle == BuildInplaceOnly || - installedPackageId pkg == hashedInstalledPackageId - (packageHashInputs sharedConfig pkg)) - - && (pkgBuildStyle == BuildInplaceOnly || - Set.null pkgStanzasAvailable) - - ------------------------------------------------------------------------------- --- * Deciding what to do: making an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - -rebuildInstallPlan :: Verbosity - -> FilePath -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> IO ( ElaboratedInstallPlan - , ElaboratedSharedConfig - , ProjectConfig ) -rebuildInstallPlan verbosity - projectRootDir - distDirLayout@DistDirLayout { - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory - } - cabalDirLayout@CabalDirLayout { - cabalPackageCacheDirectory, - cabalStoreDirectory, - cabalStorePackageDB - } - cliConfig = - runRebuild projectRootDir $ do - progsearchpath <- liftIO $ getSystemSearchPath - let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in command line args and the path - (cliConfigPersistent, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, - projectConfig) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (cliConfigPersistent, progsearchpath) $ do - - (projectConfig, projectConfigTransient) <- phaseReadProjectConfig - localPackages <- phaseReadLocalPackages projectConfig - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - solverPlan <- phaseRunSolver projectConfigTransient - compilerEtc localPackages - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfigTransient - compilerEtc - solverPlan localPackages - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - - return (elaboratedPlan, elaboratedShared, - projectConfig) - - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - return (improvedPlan, elaboratedShared, projectConfig) - - where - fileMonitorCompiler = newFileMonitorInCacheDir "compiler" - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile - - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig) - phaseReadProjectConfig = do - liftIO $ do - info verbosity "Project settings changed, reconfiguring..." - createDirectoryIfMissingVerbose verbosity False distDirectory - createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory - - projectConfig <- readProjectConfig verbosity projectRootDir - - -- The project config comming from the command line includes "build only" - -- flags that we don't cache persistently (because like all "build only" - -- flags they do not affect the value of the outcome) but that we do - -- sometimes using during planning (in particular the http transport) - let projectConfigTransient = projectConfig <> cliConfig - projectConfigPersistent = projectConfig - <> cliConfig { - projectConfigBuildOnly = mempty - } - liftIO $ writeProjectConfigFile (distProjectCacheFile "config") - projectConfigPersistent - return (projectConfigPersistent, projectConfigTransient) - - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [SourcePackage] - phaseReadLocalPackages projectConfig = do - - localCabalFiles <- findProjectPackages projectRootDir projectConfig - mapM (readSourcePackage verbosity) localCabalFiles - - - -- Configure the compiler we're using. - -- - -- This is moderately expensive and doesn't change that often so we cache - -- it independently. - -- - phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = do - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra) $ do - - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ - Cabal.configCompilerEx - hcFlavor hcPath hcPkg - progdb verbosity - - -- Note that we added the user-supplied program locations and args - -- for /all/ programs, not just those for the compiler prog and - -- compiler-related utils. In principle we don't know which programs - -- the compiler will configure (and it does vary between compilers). - -- We do know however that the compiler will only configure the - -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') - - return result - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do - -- Users are allowed to specify program locations independently for - -- each package (e.g. to use a particular version of a pre-processor - -- for some packages). However they cannot do this for the compiler - -- itself as that's just not going to work. So we check for this. - liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. - - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. - - - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> [SourcePackage] - -> Rebuild (SolverInstallPlan, PackagesImplicitSetupDeps) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, cabalPackageCacheDirectory, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programsDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - sourcePkgDb <- getSourcePackages verbosity withRepoCtx - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - foldProgress logMsg die return $ - planPackages compiler platform solver solverSettings - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - where - corePackageDbs = [GlobalPackageDB] - withRepoCtx = projectConfigWithSolverRepoContext verbosity - cabalPackageCacheDirectory - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - , let pkgname = packageName pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - stanzas = - Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] - ++ [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> (SolverInstallPlan, PackagesImplicitSetupDeps) - -> [SourcePackage] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) - (solverPlan, pkgsImplicitSetupDeps) - localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - return $ - elaborateInstallPlan - platform compiler progdb - distDirLayout - cabalDirLayout - solverPlan - pkgsImplicitSetupDeps - localPackages - sourcePackageHashes - defaultInstallDirs - projectConfigShared - projectConfigLocalPackages - (getMapMappend projectConfigSpecificPackage) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - cabalPackageCacheDirectory - projectConfigShared - projectConfigBuildOnly - - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan. - -- - -- TODO: [required eventually] maintain the ghc environment file reflecting - -- the libs available. This will need to be after plan improvement phase. - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = do - liftIO $ debug verbosity "Updating plan.json" - liftIO $ writePlanExternalRepresentation - distDirLayout - elaboratedPlan - elaboratedShared - - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - - liftIO $ debug verbosity "Improving the install plan..." - recreateDirectory verbosity True storeDirectory - storePkgIndex <- getPackageDBContents verbosity - compiler progdb platform - storePackageDb - let improvedPlan = improveInstallPlanWithPreExistingPackages - storePkgIndex - elaboratedPlan - return improvedPlan - - where - storeDirectory = cabalStoreDirectory (compilerId compiler) - storePackageDb = cabalStorePackageDB (compilerId compiler) - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } = elaboratedShared - - -programsMonitorFiles :: ProgramDb -> [MonitorFilePath] -programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (programPath prog) - ] - --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. --- -programsDbSignature :: ProgramDb -> [ConfiguredProgram] -programsDbSignature progdb = - [ prog { programMonitorFiles = [] - , programOverrideEnv = filter ((/="PATH") . fst) - (programOverrideEnv prog) } - | prog <- configuredPrograms progdb ] - -getInstalledPackages :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDBStack - -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb - -getPackageDBContents :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDB - -> Rebuild InstalledPackageIndex -getPackageDBContents verbosity compiler progdb platform packagedb = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - [packagedb] progdb platform) - liftIO $ do - createPackageDBIfMissing verbosity compiler - progdb [packagedb] - Cabal.getPackageDBContents verbosity compiler - packagedb progdb - -getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) - -> Rebuild SourcePackageDb -getSourcePackages verbosity withRepoCtx = do - (sourcePkgDb, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx - return (sourcePkgDb, repoContextRepos repoctx) - - monitorFiles . map monitorFile - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDb - -createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb - -> PackageDBStack -> IO () -createPackageDBIfMissing verbosity compiler progdb packageDbs = - case reverse packageDbs of - SpecificPackageDB dbPath : _ -> do - exists <- liftIO $ Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb False dbPath - _ -> return () - - -getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb -getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - forM_ dirs $ \dir -> do - dirExists <- liftIO $ doesDirectoryExist dir - -- TODO: turn this into a utility function - monitorFiles [if dirExists - then monitorDirectory dir - else monitorNonExistentDirectory dir] - - liftIO $ readPkgConfigDb verbosity progdb - - -recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild () -recreateDirectory verbosity createParents dir = do - liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir - monitorFiles [monitorDirectoryExistence dir] - - --- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] -packageLocationsSignature solverPlan = - [ (packageId pkg, packageSource pkg) - | InstallPlan.Configured - (ConfiguredPackage pkg _ _ _) <- InstallPlan.toList solverPlan - ] - - --- | Get the 'HashValue' for all the source packages where we use hashes, --- and download any packages required to do so. --- --- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) -getPackageSourceHashes verbosity withRepoCtx solverPlan = do - - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, packageSource pkg) - | InstallPlan.Configured - (ConfiguredPackage pkg _ _ _) <- InstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - --TODO: [required eventually] finish remote tarball functionality --- allRemoteTarballPkgs = --- [ (pkgid, ) --- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadata :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadata, - repoTarballPkgsWithoutMetadata) = - partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownload, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do - - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ - sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):_) -> (repo, map fst grp)) - . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata - ] - - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) - - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ - fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] - - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles - - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [SourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String - (SolverInstallPlan, PackagesImplicitSetupDeps) -planPackages comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = - - rememberImplicitSetupDeps (depResolverSourcePkgIndex stdResolverParams) <$> - - resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver - resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in the solver, but then - -- make sure we can cope with that in the output. - resolverParams = - - setMaxBackjumps solverSettingMaxBackjumps - - --TODO: [required eventually] should only be configurable for custom installs - -- . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - --TODO: [required eventually] should only be configurable for custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - --TODO: [required eventually] decide if we need to prefer installed for - -- global packages, or prefer latest even for global packages. Perhaps - -- should be configurable but with a different name than "upgrade-dependencies". - . setPreferenceDefault PreferLatestForSelected - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . packageDescription) - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | Dependency name ver <- solverSettingPreferences ] - - . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference where the user did not specify - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = packageName pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Nothing ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraintStanzas pkgname stanzas) - ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = packageName pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) - ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) - ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (null flags) - , pkg <- localPackages - , let pkgname = packageName pkg ] - - $ stdResolverParams - - stdResolverParams = - standardInstallPolicy - installedPkgIndex sourcePkgDb - (map SpecificSourcePackage localPackages) - - ------------------------------------------------------------------------------- --- * Install plan post-processing ------------------------------------------------------------------------------- - --- This phase goes from the InstallPlan we get from the solver and has to --- make an elaborated install plan. --- --- We go in two steps: --- --- 1. elaborate all the source packages that the solver has chosen. --- 2. swap source packages for pre-existing installed packages wherever --- possible. --- --- We do it in this order, elaborating and then replacing, because the easiest --- way to calculate the installed package ids used for the replacement step is --- from the elaborated configuration for each package. - - - - ------------------------------------------------------------------------------- --- * Install plan elaboration ------------------------------------------------------------------------------- - --- | Produce an elaborated install plan using the policy for local builds with --- a nix-style shared store. --- --- In theory should be able to make an elaborated install plan with a policy --- matching that of the classic @cabal install --user@ or @--global@ --- -elaborateInstallPlan - :: Platform -> Compiler -> ProgramDb - -> DistDirLayout - -> CabalDirLayout - -> SolverInstallPlan - -> PackagesImplicitSetupDeps - -> [SourcePackage] - -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates - -> ProjectConfigShared - -> PackageConfig - -> Map PackageName PackageConfig - -> (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan platform compiler compilerprogdb - DistDirLayout{..} - cabalDirLayout@CabalDirLayout{cabalStorePackageDB} - solverPlan pkgsImplicitSetupDeps localPackages - sourcePackageHashes - defaultInstallDirs - _sharedPackageConfig - localPackagesConfig - perPackageConfig = - (elaboratedInstallPlan, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb - } - - elaboratedInstallPlan = - flip InstallPlan.mapPreservingGraph solverPlan $ \mapDep planpkg -> - case planpkg of - InstallPlan.PreExisting pkg -> - InstallPlan.PreExisting pkg - - InstallPlan.Configured pkg -> - InstallPlan.Configured - (elaborateConfiguredPackage (fixupDependencies mapDep pkg)) - - _ -> error "elaborateInstallPlan: unexpected package state" - - -- remap the installed package ids of the direct deps, since we're - -- changing the installed package ids of all the packages to use the - -- final nix-style hashed ids. - fixupDependencies mapDep - (ConfiguredPackage pkg flags stanzas deps) = - ConfiguredPackage pkg flags stanzas deps' - where - deps' = fmap (map (\d -> d { confInstId = mapDep (confInstId d) })) deps - - elaborateConfiguredPackage :: ConfiguredPackage - -> ElaboratedConfiguredPackage - elaborateConfiguredPackage - pkg@(ConfiguredPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps) = - elaboratedPackage - where - -- Knot tying: the final elaboratedPackage includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - -- - elaboratedPackage = ElaboratedConfiguredPackage {..} - - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkUnitId (display pkgid ++ "-inplace") - - | otherwise - = assert (isJust pkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elaboratedPackage) -- recursive use of elaboratedPackage - - | otherwise - = error $ "elaborateInstallPlan: non-inplace package " - ++ " is missing a source hash: " ++ display pkgid - - -- All the other fields of the ElaboratedConfiguredPackage - -- - pkgSourceId = pkgid - pkgDescription = let Right (desc, _) = - PD.finalizePackageDescription - flags (const True) - platform (compilerInfo compiler) - [] gdesc - in desc - pkgFlagAssignment = flags - pkgFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - pkgDependencies = deps - pkgStanzasAvailable = Set.fromList stanzas - pkgStanzasRequested = - Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests ] - ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks ] - where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- These sometimes get adjusted later - pkgStanzasEnabled = Set.empty - pkgBuildTargets = [] - pkgReplTarget = Nothing - pkgBuildHaddocks = False - - pkgSourceLocation = srcloc - pkgSourceHash = Map.lookup pkgid sourcePackageHashes - pkgBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall - pkgBuildPackageDBStack = buildAndRegisterDbs - pkgRegisterPackageDBStack = buildAndRegisterDbs - pkgRequiresRegistration = isJust (Cabal.condLibrary gdesc) - - pkgSetupScriptStyle = packageSetupScriptStylePostSolver - pkgsImplicitSetupDeps pkg pkgDescription - pkgSetupScriptCliVersion = packageSetupScriptSpecVersion - pkgSetupScriptStyle pkgDescription deps - pkgSetupPackageDBStack = buildAndRegisterDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = storePackageDbs - - pkgDescriptionOverride = descOverride - - pkgVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - pkgSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - pkgDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - pkgGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - pkgProfExe = perPkgOptionFlag pkgid False packageConfigProf - pkgProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (pkgProfExeDetail, - pkgProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - pkgCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - pkgOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - pkgSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - pkgStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - pkgStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - pkgDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - pkgProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - pkgProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - pkgProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - pkgConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - pkgExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - pkgExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - pkgExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - pkgProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - pkgProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - pkgInstallDirs - | shouldBuildInplaceOnly pkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (installedUnitId pkg) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as - InstallDirs.datasubdir = "" -- 'undefined' but we have to use - } -- them as "Setup.hs configure" args - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - cabalDirLayout - (compilerId compiler) - pkgInstalledId - - pkgHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - pkgHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - pkgHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - pkgHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - pkgHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - pkgHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - pkgHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - pkgHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - pkgHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour - pkgHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - pkgHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib - - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f - -- the project config specifies values that apply to packages local to - -- but by default non-local packages get all default config values - -- the project, and can specify per-package values for any package, - | isLocalToProject pkg = local <> perpkg - | otherwise = perpkg - where - local = f localPackagesConfig - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = storePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - storePackageDbs = [ GlobalPackageDB - , cabalStorePackageDB (compilerId compiler) ] - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: HasUnitId pkg => pkg -> Bool - shouldBuildInplaceOnly pkg = Set.member (installedPackageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set InstalledPackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map installedPackageId - $ InstallPlan.reverseDependencyClosure - solverPlan - [ fakeUnitId (packageId pkg) - | pkg <- localPackages ] - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ] - - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithDownwardClosedProperty needsSharedLib - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.isDynamic compiler - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = - fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - packagesWithDownwardClosedProperty property = - Set.fromList - $ map packageId - $ InstallPlan.dependencyClosure - solverPlan - [ installedPackageId pkg - | pkg <- InstallPlan.toList solverPlan - , property pkg ] -- just the packages that satisfy the propety - --TODO: [nice to have] this does not check the config consistency, - -- e.g. a package explicitly turning off profiling, but something - -- depending on it that needs profiling. This really needs a separate - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- * profiling libs & exes, exe needs lib, recursive - -- * shared libs & exes, exe needs lib, recursive - -- * vanilla libs & exes, exe needs lib, recursive - -- * ghci or shared lib needed by TH, recursive, ghc version dependent - - ---------------------------- --- Build targets --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- data PackageTarget = ... --- data ComponentTarget = ... --- data SubComponentTarget = ... - - ---TODO: this needs to report some user target/config errors -elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget] - -> ([ComponentTarget], Maybe ComponentTarget, Bool) -elaboratePackageTargets ElaboratedConfiguredPackage{..} targets = - let buildTargets = nubComponentTargets - . map compatSubComponentTargets - . concatMap elaborateBuildTarget - $ targets - --TODO: instead of listToMaybe we should be reporting an error here - replTargets = listToMaybe - . nubComponentTargets - . map compatSubComponentTargets - . concatMap elaborateReplTarget - $ targets - buildHaddocks = HaddockDefaultComponents `elem` targets - - in (buildTargets, replTargets, buildHaddocks) - where - --TODO: need to report an error here if defaultComponents is empty - elaborateBuildTarget BuildDefaultComponents = pkgDefaultComponents - elaborateBuildTarget (BuildSpecificComponent t) = [t] - elaborateBuildTarget _ = [] - - --TODO: need to report an error here if defaultComponents is empty - elaborateReplTarget ReplDefaultComponent = take 1 pkgDefaultComponents - elaborateReplTarget (ReplSpecificComponent t) = [t] - elaborateReplTarget _ = [] - - pkgDefaultComponents = - [ ComponentTarget cname WholeComponent - | c <- Cabal.pkgComponents pkgDescription - , PD.buildable (Cabal.componentBuildInfo c) - , let cname = Cabal.componentName c - , enabledOptionalStanza cname - ] - where - enabledOptionalStanza cname = - case componentOptionalStanza cname of - Nothing -> True - Just stanza -> Map.lookup stanza pkgStanzasRequested - == Just True - - -- Not all Cabal Setup.hs versions support sub-component targets, so switch - -- them over to the whole component - compatSubComponentTargets :: ComponentTarget -> ComponentTarget - compatSubComponentTargets target@(ComponentTarget cname _subtarget) - | not setupHsSupportsSubComponentTargets - = ComponentTarget cname WholeComponent - | otherwise = target - - -- Actually the reality is that no current version of Cabal's Setup.hs - -- build command actually support building specific files or modules. - setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] - - nubComponentTargets :: [ComponentTarget] -> [ComponentTarget] - nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@(ComponentTarget cname _) -> (cname, t)) - - -- If we're building the whole component then that the only target all we - -- need, otherwise we can have several targets within the component. - wholeComponentOverrides :: [ComponentTarget] -> [ComponentTarget] - wholeComponentOverrides ts = - case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of - (t:_) -> [t] - [] -> ts - - -pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool -pkgHasEphemeralBuildTargets pkg = - isJust (pkgReplTarget pkg) - || (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg - , subtarget /= WholeComponent ] - --- | The components that we'll build all of, meaning that after they're built --- we can skip building them again (unlike with building just some modules or --- other files within a component). --- -pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName -pkgBuildTargetWholeComponents pkg = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ] - - ------------------------------------------------------------------------------- --- * Install plan pruning ------------------------------------------------------------------------------- - --- | Given a set of package targets (and optionally component targets within --- those packages), take the subset of the install plan needed to build those --- targets. Also, update the package config to specify which optional stanzas --- to enable, and which targets within each package to build. --- -pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets perPkgTargetsMap = - either (\_ -> assert False undefined) id - . InstallPlan.new False - . PackageIndex.fromList - -- We have to do this in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 perPkgTargetsMap - . InstallPlan.toList - --- The first pass does three things: --- --- * Set the build targets based on the user targets (but not rev deps yet). --- * A first go at determining which optional stanzas (testsuites, benchmarks) --- are needed. We have a second go in the next pass. --- * Take the dependency closure using pruned dependencies. We prune deps that --- are used only by unneeded optional stanzas. These pruned deps are only --- used for the dependency closure and are not persisted in this pass. --- -pruneInstallPlanPass1 :: Map InstalledPackageId [PackageTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass1 perPkgTargetsMap pkgs = - map fst $ - dependencyClosure - (installedPackageId . fst) -- the pkg id - snd -- the pruned deps - [ (pkg', pruneOptionalDependencies pkg') - | pkg <- pkgs - , let pkg' = mapConfiguredPackage - (pruneOptionalStanzas . setBuildTargets) pkg - ] - (Map.keys perPkgTargetsMap) - where - -- Elaborate and set the targets we'll build for this package. This is just - -- based on the targets from the user, not targets implied by reverse - -- depencencies. Those comes in the second pass once we know the rev deps. - -- - setBuildTargets pkg = - pkg { - pkgBuildTargets = buildTargets, - pkgReplTarget = replTarget, - pkgBuildHaddocks = buildHaddocks - } - where - (buildTargets, replTarget, buildHaddocks) - = elaboratePackageTargets pkg targets - targets = fromMaybe [] - $ Map.lookup (installedPackageId pkg) perPkgTargetsMap - - -- Decide whether or not to enable testsuites and benchmarks - -- - -- The testsuite and benchmark targets are somewhat special in that we need - -- to configure the packages with them enabled, and we need to do that even - -- if we only want to build one of several testsuites. - -- - -- There are two cases in which we will enable the testsuites (or - -- benchmarks): if one of the targets is a testsuite, or if all of the - -- testsuite depencencies are already cached in the store. The rationale - -- for the latter is to minimise how often we have to reconfigure due to - -- the particular targets we choose to build. Otherwise choosing to build - -- a testsuite target, and then later choosing to build an exe target - -- would involve unnecessarily reconfiguring the package with testsuites - -- disabled. Technically this introduces a little bit of stateful - -- behaviour to make this "sticky", but it should be benign. - -- - pruneOptionalStanzas pkg = pkg { pkgStanzasEnabled = stanzas } - where - stanzas :: Set OptionalStanza - stanzas = optionalStanzasRequiredByTargets pkg - <> optionalStanzasRequestedByDefault pkg - <> optionalStanzasWithDepsAvailable availablePkgs pkg - - -- Calculate package depencencies but cut out those needed only by - -- optional stanzas that we've determined we will not enable. - -- These pruned deps are not persisted in this pass since they're based on - -- the optional stanzas and we'll make further tweaks to the optional - -- stanzas in the next pass. - -- - pruneOptionalDependencies :: ElaboratedPlanPackage -> [InstalledPackageId] - pruneOptionalDependencies (InstallPlan.Configured pkg) = - (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg) - where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - stanzas = pkgStanzasEnabled pkg - pruneOptionalDependencies pkg = - CD.flatDeps (depends pkg) - - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequiredByTargets pkg = - Set.fromList - [ stanza - | ComponentTarget cname _ <- pkgBuildTargets pkg - ++ maybeToList (pkgReplTarget pkg) - , stanza <- maybeToList (componentOptionalStanza cname) - ] - - optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequestedByDefault = - Map.keysSet - . Map.filter (id :: Bool -> Bool) - . pkgStanzasRequested - - availablePkgs = - Set.fromList - [ installedPackageId pkg - | InstallPlan.PreExisting pkg <- pkgs ] - -optionalStanzasWithDepsAvailable :: Set InstalledPackageId - -> ElaboratedConfiguredPackage - -> Set OptionalStanza -optionalStanzasWithDepsAvailable availablePkgs pkg = - Set.fromList - [ stanza - | stanza <- Set.toList (pkgStanzasAvailable pkg) - , let deps :: [InstalledPackageId] - deps = map installedPackageId - $ CD.select (optionalStanzaDeps stanza) - (pkgDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] - where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True - optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - - --- The second pass does three things: --- --- * A second go at deciding which optional stanzas to enable. --- * Prune the depencencies based on the final choice of optional stanzas. --- * Extend the targets within each package to build, now we know the reverse --- depencencies, ie we know which libs are needed as deps by other packages. --- --- Achieving sticky behaviour with enabling\/disabling optional stanzas is --- tricky. The first approximation was handled by the first pass above, but --- it's not quite enough. That pass will enable stanzas if all of the deps --- of the optional stanza are already instaled /in the store/. That's important --- but it does not account for depencencies that get built inplace as part of --- the project. We cannot take those inplace build deps into account in the --- pruning pass however because we don't yet know which ones we're going to --- build. Once we do know, we can have another go and enable stanzas that have --- all their deps available. Now we can consider all packages in the pruned --- plan to be available, including ones we already decided to build from --- source. --- --- Deciding which targets to build depends on knowing which packages have --- reverse dependencies (ie are needed). This requires the result of first --- pass, which is another reason we have to split it into two passes. --- --- Note that just because we might enable testsuites or benchmarks (in the --- first or second pass) doesn't mean that we build all (or even any) of them. --- That depends on which targets we picked in the first pass. --- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs - where - setStanzasDepsAndTargets pkg = - pkg { - pkgStanzasEnabled = stanzas, - pkgDependencies = CD.filterDeps keepNeeded (pkgDependencies pkg), - pkgBuildTargets = pkgBuildTargets pkg ++ targetsRequiredForRevDeps - } - where - stanzas :: Set OptionalStanza - stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs pkg - - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - - targetsRequiredForRevDeps = - [ ComponentTarget CLibName WholeComponent - -- if anything needs this pkg, build the library component - | installedPackageId pkg `Set.member` hasReverseLibDeps - ] - --TODO: also need to track build-tool rev-deps for exes - - availablePkgs :: Set InstalledPackageId - availablePkgs = Set.fromList (map installedPackageId pkgs) - - hasReverseLibDeps :: Set InstalledPackageId - hasReverseLibDeps = - Set.fromList [ depid | pkg <- pkgs - , depid <- CD.flatDeps (depends pkg) ] - - -mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage) - -> ElaboratedPlanPackage - -> ElaboratedPlanPackage -mapConfiguredPackage f (InstallPlan.Configured pkg) = - InstallPlan.Configured (f pkg) -mapConfiguredPackage _ pkg = pkg - -componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza -componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas -componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas -componentOptionalStanza _ = Nothing - - -dependencyClosure :: (pkg -> InstalledPackageId) - -> (pkg -> [InstalledPackageId]) - -> [pkg] - -> [InstalledPackageId] - -> [pkg] -dependencyClosure pkgid deps allpkgs = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs graph - . map pkgidToVertex - where - (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs - -dependencyGraph :: (pkg -> InstalledPackageId) - -> (pkg -> [InstalledPackageId]) - -> [pkg] - -> (Graph.Graph, - Graph.Vertex -> pkg, - InstalledPackageId -> Graph.Vertex) -dependencyGraph pkgid deps pkgs = - (graph, vertexToPkg', pkgidToVertex') - where - (graph, vertexToPkg, pkgidToVertex) = - Graph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg ) - | pkg <- pkgs ] - vertexToPkg' = (\(pkg,_,_) -> pkg) - . vertexToPkg - pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure") - . pkgidToVertex - - ---------------------------- --- Setup.hs script policy --- - --- Handling for Setup.hs scripts is a bit tricky, part of it lives in the --- solver phase, and part in the elaboration phase. We keep the helper --- functions for both phases together here so at least you can see all of it --- in one place. --- --- There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. In case 3 we also have --- to build an external Setup.hs script because the package needs a later --- Cabal lib version than we can support internally. --- --- data SetupScriptStyle = ... -- see ProjectPlanning.Types - --- | Work out the 'SetupScriptStyle' given the package description. --- --- This only works on original packages before we give them to the solver, --- since after the solver some implicit setup deps are made explicit. --- --- See 'rememberImplicitSetupDeps' and 'packageSetupScriptStylePostSolver'. --- -packageSetupScriptStylePreSolver :: PD.PackageDescription -> SetupScriptStyle -packageSetupScriptStylePreSolver pkg - | buildType == PD.Custom - , isJust (PD.setupBuildInfo pkg) - = SetupCustomExplicitDeps - - | buildType == PD.Custom - = SetupCustomImplicitDeps - - | PD.specVersion pkg > cabalVersion -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib - where - buildType = fromMaybe PD.Custom (PD.buildType pkg) - - --- | Part of our Setup.hs handling policy is implemented by getting the solver --- to work out setup dependencies for packages. The solver already handles --- packages that explicitly specify setup dependencies, but we can also tell --- the solver to treat other packages as if they had setup dependencies. --- That's what this function does, it gets called by the solver for all --- packages that don't already have setup dependencies. --- --- The dependencies we want to add is different for each 'SetupScriptStyle'. --- --- Note that adding default deps means these deps are actually /added/ to the --- packages that we get out of the solver in the 'SolverInstallPlan'. Making --- implicit setup deps explicit is a problem in the post-solver stages because --- we still need to distinguish the case of explicit and implict setup deps. --- See 'rememberImplicitSetupDeps'. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] -defaultSetupDeps compiler platform pkg = - case packageSetupScriptStylePreSolver pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ - [ Dependency depPkgname anyVersion - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ - [ Dependency cabalPkgname cabalConstraint - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be >= 1.18 < 2 - -- - cabalConstraint = orLaterVersion cabalCompatMinVer - `intersectVersionRanges` - orLaterVersion (PD.specVersion pkg) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = Version [1,25] [] - -- In principle we can talk to any old Cabal version, and we need to - -- be able to do that for custom Setup scripts that require older - -- Cabal lib versions. However in practice we have currently have - -- problems with Cabal-1.16. (1.16 does not know about build targets) - -- If this is fixed we can relax this constraint. - cabalCompatMinVer = Version [1,18] [] - - -- For other build types (like Simple) if we still need to compile an - -- external Setup.hs, it'll be one of the simple ones that only depends - -- on Cabal and base. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint - , Dependency basePkgname anyVersion ] - where - cabalConstraint = orLaterVersion (PD.specVersion pkg) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ display (packageId pkg) - - --- | See 'rememberImplicitSetupDeps' for details. -type PackagesImplicitSetupDeps = Set InstalledPackageId - --- | A consequence of using 'defaultSetupDeps' in 'planPackages' is that by --- making implicit setup deps explicit we loose track of which packages --- originally had implicit setup deps. That's important because we do still --- have different behaviour based on the setup style (in particular whether to --- compile a Setup.hs script with version macros). --- --- So we remember the necessary information in an auxilliary set and use it --- in 'packageSetupScriptStylePreSolver' to recover the full info. --- -rememberImplicitSetupDeps :: SourcePackageIndex.PackageIndex SourcePackage - -> SolverInstallPlan - -> (SolverInstallPlan, PackagesImplicitSetupDeps) -rememberImplicitSetupDeps sourcePkgIndex plan = - (plan, pkgsImplicitSetupDeps) - where - pkgsImplicitSetupDeps = - Set.fromList - [ installedPackageId pkg - | InstallPlan.Configured - pkg@(ConfiguredPackage newpkg _ _ _) <- InstallPlan.toList plan - -- has explicit setup deps now - , hasExplicitSetupDeps newpkg - -- but originally had no setup deps - , let Just origpkg = SourcePackageIndex.lookupPackageId - sourcePkgIndex (packageId pkg) - , not (hasExplicitSetupDeps origpkg) - ] - - hasExplicitSetupDeps = - (SetupCustomExplicitDeps==) - . packageSetupScriptStylePreSolver - . PD.packageDescription . packageDescription - - --- | Use the extra info saved by 'rememberImplicitSetupDeps' to let us work --- out the correct 'SetupScriptStyle'. This should give the same result as --- 'packageSetupScriptStylePreSolver' gave prior to munging the package info --- through the solver. --- -packageSetupScriptStylePostSolver :: Set InstalledPackageId - -> ConfiguredPackage - -> PD.PackageDescription - -> SetupScriptStyle -packageSetupScriptStylePostSolver pkgsImplicitSetupDeps pkg pkgDescription = - case packageSetupScriptStylePreSolver pkgDescription of - SetupCustomExplicitDeps - | Set.member (installedPackageId pkg) pkgsImplicitSetupDeps - -> SetupCustomImplicitDeps - other -> other - - --- | Work out which version of the Cabal spec we will be using to talk to the --- Setup.hs interface for this package. --- --- This depends somewhat on the 'SetupScriptStyle' but most cases are a result --- of what the solver picked for us, based on the explicit setup deps or the --- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: Package pkg - => SetupScriptStyle - -> PD.PackageDescription - -> ComponentDeps [pkg] - -> Version - --- We're going to be using the internal Cabal library, so the spec version of --- that is simply the version of the Cabal library that cabal-install has been --- built with. -packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ = - cabalVersion - --- If we happen to be building the Cabal lib itself then because that --- bootstraps itself then we use the version of the lib we're building. -packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ - | packageName pkg == cabalPkgname - = packageVersion pkg - --- In all other cases we have a look at what version of the Cabal lib the --- solver picked. Or if it didn't depend on Cabal at all (which is very rare) --- then we look at the .cabal file to see what spec version it declares. -packageSetupScriptSpecVersion _ pkg deps = - case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of - Just dep -> packageVersion dep - Nothing -> PD.specVersion pkg - - -cabalPkgname, basePkgname :: PackageName -cabalPkgname = PackageName "Cabal" -basePkgname = PackageName "base" - - -legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] -legacyCustomSetupPkgs compiler (Platform _ os) = - map PackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "old-time", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "unix" | os /= Windows ] - ++ [ "ghc-prim" | isGHC ] - ++ [ "template-haskell" | isGHC ] - where - isGHC = compilerCompatFlavor GHC compiler - - -- This util is copied here just in this branch to avoid requiring a new - -- Cabal version. The master branch already does the right thing. - compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool - compilerCompatFlavor flavor comp = - flavor == compilerFlavor comp - || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] - --- The other aspects of our Setup.hs policy lives here where we decide on --- the 'SetupScriptOptions'. --- --- Our current policy for the 'SetupCustomImplicitDeps' case is that we --- try to make the implicit deps cover everything, and we don't allow the --- compiler to pick up other deps. This may or may not be sustainable, and --- we might have to allow the deps to be non-exclusive, but that itself would --- be tricky since we would have to allow the Setup access to all the packages --- in the store and local dbs. - -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions -setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..} deps) - ElaboratedSharedConfig{..} srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion pkgSetupScriptCliVersion, - useCabalSpecVersion = Just pkgSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = pkgSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (installedPackageId ipkg, packageId ipkg) - | ipkg <- CD.setupDeps deps ], - useDependenciesExclusive = True, - useVersionMacros = pkgSetupScriptStyle == SetupCustomExplicitDeps, - useProgramConfig = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock - } - - --- | To be used for the input for elaborateInstallPlan. --- --- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates -userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: CabalDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory} - compid ipkgid = - InstallDirs.InstallDirs {..} - where - prefix = cabalStorePackageDirectory compid ipkgid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - dynlibdir = libdir - libexecdir = prefix "libexec" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - ---TODO: [code cleanup] perhaps reorder this code --- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, --- make the various Setup.hs {configure,build,copy} flags - - -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage - pkg@ElaboratedConfiguredPackage{..} - pkgdeps) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - assert (sanityCheckElaboratedConfiguredPackage sharedConfig pkg) - Cabal.ConfigFlags {..} - where - configDistPref = toFlag builddir - configVerbosity = toFlag verbosity - - configIPID = toFlag (display (installedUnitId pkg)) - - configProgramPaths = Map.toList pkgProgramPaths - configProgramArgs = Map.toList pkgProgramArgs - configProgramPathExtra = toNubList pkgProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag pkgVanillaLib - configSharedLib = toFlag pkgSharedLib - configDynExe = toFlag pkgDynExe - configGHCiLib = toFlag pkgGHCiLib - configProfExe = mempty - configProfLib = toFlag pkgProfLib - configProf = toFlag pkgProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag pkgProfExeDetail - configProfLibDetail = toFlag pkgProfLibDetail - - configCoverage = toFlag pkgCoverage - configLibCoverage = mempty - - configOptimization = toFlag pkgOptimization - configSplitObjs = toFlag pkgSplitObjs - configStripExes = toFlag pkgStripExes - configStripLibs = toFlag pkgStripLibs - configDebugInfo = toFlag pkgDebugInfo - configAllowNewer = mempty -- we use configExactConfiguration True - - configConfigurationsFlags = pkgFlagAssignment - configConfigureArgs = pkgConfigureScriptArgs - configExtraLibDirs = pkgExtraLibDirs - configExtraFrameworkDirs = pkgExtraFrameworkDirs - configExtraIncludeDirs = pkgExtraIncludeDirs - configProgPrefix = maybe mempty toFlag pkgProgPrefix - configProgSuffix = maybe mempty toFlag pkgProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - pkgInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - configDependencies = [ (packageName (Installed.sourcePackageId deppkg), - Installed.installedUnitId deppkg) - | deppkg <- CD.nonSetupDeps pkgdeps ] - configConstraints = [ thisPackageVersion (packageId deppkg) - | deppkg <- CD.nonSetupDeps pkgdeps ] - - -- explicitly clear, then our package db stack - -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just pkgBuildPackageDBStack - - configTests = toFlag (TestStanzas `Set.member` pkgStanzasEnabled) - configBenchmarks = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled) - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags -setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = - Cabal.BuildFlags { - buildProgramPaths = mempty, --unused, set at configure time - buildProgramArgs = mempty, --unused, set at configure time - buildVerbosity = toFlag verbosity, - buildDistPref = toFlag builddir, - buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildArgs = mempty -- unused, passed via args not flags - } - - -setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs pkg = - map (showComponentTarget pkg) (pkgBuildTargets pkg) - - -showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String -showComponentTarget pkg = - showBuildTarget . toBuildTarget - where - showBuildTarget t = - Cabal.showBuildTarget (qlBuildTarget t) (packageId pkg) t - - qlBuildTarget Cabal.BuildTargetComponent{} = Cabal.QL2 - qlBuildTarget _ = Cabal.QL3 - - toBuildTarget :: ComponentTarget -> Cabal.BuildTarget - toBuildTarget (ComponentTarget cname subtarget) = - case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname - - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags -setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = - Cabal.ReplFlags { - replProgramPaths = mempty, --unused, set at configure time - replProgramArgs = mempty, --unused, set at configure time - replVerbosity = toFlag verbosity, - replDistPref = toFlag builddir, - replReload = mempty --only used as callback from repl - } - - -setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] -setupHsReplArgs pkg = - maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg) - --TODO: should be able to give multiple modules in one component - - -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.CopyFlags -setupHsCopyFlags _ _ verbosity builddir = - Cabal.CopyFlags { - --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right - -- thing, but perhaps we ought really to copy into an image dir and do - -- some sanity checks and move into the final location ourselves - copyDest = toFlag InstallDirs.NoCopyDest, - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity - } - -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case pkgBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regVerbosity = toFlag verbosity - } - -setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.HaddockFlags -setupHsHaddockFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = mempty, --unused, set at configure time - haddockProgramArgs = mempty, --unused, set at configure time - haddockHoogle = toFlag pkgHaddockHoogle, - haddockHtml = toFlag pkgHaddockHtml, - haddockHtmlLocation = maybe mempty toFlag pkgHaddockHtmlLocation, - haddockForHackage = mempty, --TODO: new flag - haddockExecutables = toFlag pkgHaddockExecutables, - haddockTestSuites = toFlag pkgHaddockTestSuites, - haddockBenchmarks = toFlag pkgHaddockBenchmarks, - haddockInternal = toFlag pkgHaddockInternal, - haddockCss = maybe mempty toFlag pkgHaddockCss, - haddockHscolour = toFlag pkgHaddockHscolour, - haddockHscolourCss = maybe mempty toFlag pkgHaddockHscolourCss, - haddockContents = maybe mempty toFlag pkgHaddockContents, - haddockDistPref = toFlag builddir, - haddockKeepTempFiles = mempty, --TODO: from build settings - haddockVerbosity = toFlag verbosity - } - -{- -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags _ _ verbosity builddir = - Cabal.TestFlags { - } --} - ------------------------------------------------------------------------------- --- * Sharing installed packages ------------------------------------------------------------------------------- - --- --- Nix style store management for tarball packages --- --- So here's our strategy: --- --- We use a per-user nix-style hashed store, but /only/ for tarball packages. --- So that includes packages from hackage repos (and other http and local --- tarballs). For packages in local directories we do not register them into --- the shared store by default, we just build them locally inplace. --- --- The reason we do it like this is that it's easy to make stable hashes for --- tarball packages, and these packages benefit most from sharing. By contrast --- unpacked dir packages are harder to hash and they tend to change more --- frequently so there's less benefit to sharing them. --- --- When using the nix store approach we have to run the solver *without* --- looking at the packages installed in the store, just at the source packages --- (plus core\/global installed packages). Then we do a post-processing pass --- to replace configured packages in the plan with pre-existing ones, where --- possible. Where possible of course means where the nix-style package hash --- equals one that's already in the store. --- --- One extra wrinkle is that unless we know package tarball hashes upfront, we --- will have to download the tarballs to find their hashes. So we have two --- options: delay replacing source with pre-existing installed packages until --- the point during the execution of the install plan where we have the --- tarball, or try to do as much up-front as possible and then check again --- during plan execution. The former isn't great because we would end up --- telling users we're going to re-install loads of packages when in fact we --- would just share them. It'd be better to give as accurate a prediction as --- we can. The latter is better for users, but we do still have to check --- during plan execution because it's important that we don't replace existing --- installed packages even if they have the same package hash, because we --- don't guarantee ABI stability. - --- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but --- not replace installed packages with ghc-pkg. - -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs -packageHashInputs - pkgshared - pkg@ElaboratedConfiguredPackage{ - pkgSourceId, - pkgSourceHash = Just srchash, - pkgDependencies - } = - PackageHashInputs { - pkgHashPkgId = pkgSourceId, - pkgHashSourceHash = srchash, - pkgHashDirectDeps = Set.fromList - [ installedPackageId dep - | dep <- CD.select relevantDeps pkgDependencies ], - pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - -packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ display (packageId pkg) - -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs -packageHashConfigInputs - ElaboratedSharedConfig{..} - ElaboratedConfiguredPackage{..} = - - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = pkgFlagAssignment, - pkgHashConfigureScriptArgs = pkgConfigureScriptArgs, - pkgHashVanillaLib = pkgVanillaLib, - pkgHashSharedLib = pkgSharedLib, - pkgHashDynExe = pkgDynExe, - pkgHashGHCiLib = pkgGHCiLib, - pkgHashProfLib = pkgProfLib, - pkgHashProfExe = pkgProfExe, - pkgHashProfLibDetail = pkgProfLibDetail, - pkgHashProfExeDetail = pkgProfExeDetail, - pkgHashCoverage = pkgCoverage, - pkgHashOptimization = pkgOptimization, - pkgHashSplitObjs = pkgSplitObjs, - pkgHashStripLibs = pkgStripLibs, - pkgHashStripExes = pkgStripExes, - pkgHashDebugInfo = pkgDebugInfo, - pkgHashExtraLibDirs = pkgExtraLibDirs, - pkgHashExtraFrameworkDirs = pkgExtraFrameworkDirs, - pkgHashExtraIncludeDirs = pkgExtraIncludeDirs, - pkgHashProgPrefix = pkgProgPrefix, - pkgHashProgSuffix = pkgProgSuffix - } - - --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by pre-existing --- installed packages whenever they exist. --- -improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan = - replaceWithPreExisting installPlan - [ ipkg - | InstallPlan.Configured pkg - <- InstallPlan.reverseTopologicalOrder installPlan - , ipkg <- maybeToList (canPackageBeImproved pkg) ] - where - --TODO: sanity checks: - -- * the installed package must have the expected deps etc - -- * the installed package must not be broken, valid dep closure - - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. - - canPackageBeImproved pkg = - PackageIndex.lookupUnitId - installedPkgIndex (installedPackageId pkg) - - replaceWithPreExisting = - foldl' (\plan ipkg -> InstallPlan.preexisting - (installedPackageId ipkg) ipkg plan) +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | Planning how to build everything in a project. +-- +module Distribution.Client.ProjectPlanning ( + -- * elaborated install plan types + ElaboratedInstallPlan, + ElaboratedConfiguredPackage(..), + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Producing the elaborated install plan + rebuildProjectConfig, + rebuildInstallPlan, + + -- * Build targets + availableTargets, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentTarget(..), + SubComponentTarget(..), + showComponentTarget, + nubComponentTargets, + + -- * Selecting a plan subset + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + + -- * Utils required for building + pkgHasEphemeralBuildTargets, + elabBuildTargetWholeComponents, + + -- * Setup.hs CLI flags for building + setupHsScriptOptions, + setupHsConfigureFlags, + setupHsConfigureArgs, + setupHsBuildFlags, + setupHsBuildArgs, + setupHsReplFlags, + setupHsReplArgs, + setupHsTestFlags, + setupHsTestArgs, + setupHsCopyFlags, + setupHsRegisterFlags, + setupHsHaddockFlags, + + packageHashInputs, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.PackageHash +import Distribution.Client.RebuildMonad +import Distribution.Client.Store +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanOutput + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import qualified Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.DistDirLayout +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import qualified Hackage.Security.Client as Sec +import Distribution.Client.Setup hiding (packageName, cabalVersion) +import Distribution.Utils.NubList +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings + +import Distribution.ModuleName +import Distribution.Package hiding + (InstalledPackageId, installedPackageId) +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Compiler hiding (Flag) +import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate +import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Setup + (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import qualified Distribution.Simple.Configure as Cabal +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.LocalBuildInfo + ( Component(..), pkgComponents, componentBuildInfo + , componentName ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.FullUnitId +import Distribution.Backpack +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils hiding (matchFileGlob) +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text + +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph(IsNode(..)) + +import Text.PrettyPrint hiding ((<>)) +import qualified Text.PrettyPrint as Disp +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Monad +import qualified Data.Traversable as T +import Control.Monad.State as State +import Control.Exception +import Data.List (groupBy) +import Data.Either +import Data.Function +import System.FilePath + +------------------------------------------------------------------------------ +-- * Elaborated install plan +------------------------------------------------------------------------------ + +-- "Elaborated" -- worked out with great care and nicety of detail; +-- executed with great minuteness: elaborate preparations; +-- elaborate care. +-- +-- So here's the idea: +-- +-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc +-- all passed in as separate args and which are then further selected, +-- transformed etc during the execution of the build. Instead we construct +-- an elaborated install plan that includes everything we will need, and then +-- during the execution of the plan we do as little transformation of this +-- info as possible. +-- +-- So we're trying to split the work into two phases: construction of the +-- elaborated install plan (which as far as possible should be pure) and +-- then simple execution of that plan without any smarts, just doing what the +-- plan says to do. +-- +-- So that means we need a representation of this fully elaborated install +-- plan. The representation consists of two parts: +-- +-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a +-- representation of source packages that includes a lot more detail about +-- that package's individual configuration +-- +-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for +-- every package in a plan. Rather than duplicate that info every entry in +-- the 'GenericInstallPlan' we keep that separately. +-- +-- The division between the shared and per-package config is /not set in stone +-- for all time/. For example if we wanted to generalise the install plan to +-- describe a situation where we want to build some packages with GHC and some +-- with GHCJS then the platform and compiler would no longer be shared between +-- all packages but would have to be per-package (probably with some sanity +-- condition on the graph structure). +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- type ElaboratedInstallPlan = ... +-- type ElaboratedPlanPackage = ... +-- data ElaboratedSharedConfig = ... +-- data ElaboratedConfiguredPackage = ... +-- data BuildStyle = + + +-- | Check that an 'ElaboratedConfiguredPackage' actually makes +-- sense under some 'ElaboratedSharedConfig'. +sanityCheckElaboratedConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage sharedConfig + elab@ElaboratedConfiguredPackage{..} = + (case elabPkgOrComp of + ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg + ElabComponent comp -> sanityCheckElaboratedComponent elab comp) + + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + . assert (elabBuildStyle == BuildInplaceOnly || + elabComponentId == hashedInstalledPackageId + (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) + `Set.intersection` elabStanzasAvailable)) + + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert (elabBuildStyle == BuildInplaceOnly || + Set.null elabStanzasAvailable) + +sanityCheckElaboratedComponent + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = + + -- Should not be building bench or test if not inplace. + assert (elabBuildStyle == BuildInplaceOnly || + case compComponentName of + Nothing -> True + Just CLibName -> True + Just (CSubLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False) + + +sanityCheckElaboratedPackage + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = + -- we should only have enabled stanzas that actually can be built + -- (according to the solver) + assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) + + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert (Map.keysSet (Map.filter id elabStanzasRequested) + `Set.isSubsetOf` pkgStanzasEnabled) + +------------------------------------------------------------------------------ +-- * Deciding what to do: making an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- | Return the up-to-date project config and information about the local +-- packages within the project. +-- +rebuildProjectConfig :: Verbosity + -> DistDirLayout + -> ProjectConfig + -> IO (ProjectConfig, [UnresolvedSourcePackage]) +rebuildProjectConfig verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distDirectory, + distProjectCacheFile, + distProjectCacheDirectory + } + cliConfig = do + + (projectConfig, localPackages) <- + runRebuild distProjectRootDirectory $ + rerunIfChanged verbosity fileMonitorProjectConfig () $ do + + projectConfig <- phaseReadProjectConfig + localPackages <- phaseReadLocalPackages projectConfig + return (projectConfig, localPackages) + + return (projectConfig <> cliConfig, localPackages) + + where + fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") + + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfig + phaseReadProjectConfig = do + liftIO $ do + info verbosity "Project settings changed, reconfiguring..." + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + readProjectConfig verbosity distDirLayout + + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages :: ProjectConfig -> Rebuild [UnresolvedSourcePackage] + phaseReadLocalPackages projectConfig = do + localCabalFiles <- findProjectPackages distDirLayout projectConfig + mapM (readSourcePackage verbosity) localCabalFiles + + +-- | Return an up-to-date elaborated install plan. +-- +-- Two variants of the install plan are returned: with and without packages +-- from the store. That is, the \"improved\" plan where source packages are +-- replaced by pre-existing installed packages from the store (when their ids +-- match), and also the original elaborated plan which uses primarily source +-- packages. + +-- The improved plan is what we use for building, but the original elaborated +-- plan is useful for reporting and configuration. For example the @freeze@ +-- command needs the source package info to know about flag choices and +-- dependencies of executables and setup scripts. +-- +rebuildInstallPlan :: Verbosity + -> DistDirLayout -> CabalDirLayout + -> ProjectConfig + -> [UnresolvedSourcePackage] + -> IO ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig ) + -- ^ @(improvedPlan, elaboratedPlan, _, _)@ +rebuildInstallPlan verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distProjectCacheFile + } + CabalDirLayout { + cabalStoreDirLayout + } = \projectConfig localPackages -> + runRebuild distProjectRootDirectory $ do + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } + + -- The overall improved plan is cached + rerunIfChanged verbosity fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) $ do + + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared) <- + rerunIfChanged verbosity fileMonitorElaboratedPlan + (projectConfigMonitored, localPackages, + progsearchpath) $ do + + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB) + <- phaseRunSolver projectConfig + compilerEtc + localPackages + (elaboratedPlan, + elaboratedShared) <- phaseElaboratePlan projectConfig + compilerEtc pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared) + + -- The improved plan changes each time we install something, whereas + -- the underlying elaborated plan only changes when input config + -- changes, so it's worth caching them separately. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared) + + where + fileMonitorCompiler = newFileMonitorInCacheDir "compiler" + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile + + + -- Configure the compiler we're using. + -- + -- This is moderately expensive and doesn't change that often so we cache + -- it independently. + -- + phaseConfigureCompiler :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = do + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged verbosity fileMonitorCompiler + (hcFlavor, hcPath, hcPkg, progsearchpath, + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra) $ do + + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- liftIO $ + Cabal.configCompilerEx + hcFlavor hcPath hcPkg + progdb verbosity + + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + + return result + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + -- Users are allowed to specify program locations independently for + -- each package (e.g. to use a particular version of a pre-processor + -- for some packages). However they cannot do this for the compiler + -- itself as that's just not going to work. So we check for this. + liftIO $ checkBadPerPackageCompilerPaths + (configuredPrograms compilerprogdb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) + + --TODO: [required eventually] find/configure other programs that the + -- user specifies. + + --TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. + + + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> [UnresolvedSourcePackage] + -> Rebuild (SolverInstallPlan, PkgConfigDb) + phaseRunSolver projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages = + rerunIfChanged verbosity fileMonitorSolverPlan + (solverSettings, + localPackages, localPackagesEnabledStanzas, + compiler, platform, programDbSignature progdb) $ do + + installedPkgIndex <- getInstalledPackages verbosity + compiler progdb platform + corePackageDbs + sourcePkgDb <- getSourcePackages verbosity withRepoCtx + (solverSettingIndexState solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + --TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- chooseSolver verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + plan <- foldProgress logMsg (die' verbosity) return $ + planPackages verbosity compiler platform solver solverSettings + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages localPackagesEnabledStanzas + return (plan, pkgConfigDB) + where + corePackageDbs = [GlobalPackageDB] + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + , let pkgname = packageName pkg + testsEnabled = lookupLocalPackageConfig + packageConfigTests + projectConfig pkgname + benchmarksEnabled = lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig pkgname + stanzas = + Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled ] + ++ [ (BenchStanzas , enabled) + | enabled <- flagToList benchmarksEnabled ] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [SourcePackage loc] + -> Rebuild ( ElaboratedInstallPlan + , ElaboratedSharedConfig ) + phaseElaboratePlan ProjectConfig { + projectConfigShared, + projectConfigLocalPackages, + projectConfigSpecificPackage, + projectConfigBuildOnly + } + (compiler, platform, progdb) pkgConfigDB + solverPlan localPackages = do + + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged verbosity fileMonitorSourceHashes + (packageLocationsSignature solverPlan) $ + getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + (elaboratedPlan, elaboratedShared) + <- liftIO . runLogProgress verbosity $ + elaborateInstallPlan + verbosity + platform compiler progdb pkgConfigDB + distDirLayout + cabalStoreDirLayout + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + projectConfigShared + projectConfigLocalPackages + (getMapMappend projectConfigSpecificPackage) + let instantiatedPlan = instantiateInstallPlan elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + debug verbosity "Updating plan.json" + writePlanExternalRepresentation + distDirLayout + elaboratedPlan + elaboratedShared + + + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do + + liftIO $ debug verbosity "Improving the install plan..." + storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid + let improvedPlan = improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) + -- TODO: [nice to have] having checked which packages from the store + -- we're using, it may be sensible to sanity check those packages + -- by loading up the compiler package db and checking everything + -- matches up as expected, e.g. no dangling deps, files deleted. + return improvedPlan + where + compid = compilerId (pkgConfigCompiler elaboratedShared) + + +programsMonitorFiles :: ProgramDb -> [MonitorFilePath] +programsMonitorFiles progdb = + [ monitor + | prog <- configuredPrograms progdb + , monitor <- monitorFileSearchPath (programMonitorFiles prog) + (programPath prog) + ] + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +-- +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog { programMonitorFiles = [] + , programOverrideEnv = filter ((/="PATH") . fst) + (programOverrideEnv prog) } + | prog <- configuredPrograms progdb ] + +getInstalledPackages :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDBStack + -> Rebuild InstalledPackageIndex +getInstalledPackages verbosity compiler progdb platform packagedbs = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + packagedbs progdb platform) + liftIO $ IndexUtils.getInstalledPackages + verbosity compiler + packagedbs progdb + +{- +--TODO: [nice to have] use this but for sanity / consistency checking +getPackageDBContents :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDB + -> Rebuild InstalledPackageIndex +getPackageDBContents verbosity compiler progdb platform packagedb = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + [packagedb] progdb platform) + liftIO $ do + createPackageDBIfMissing verbosity compiler progdb packagedb + Cabal.getPackageDBContents verbosity compiler + packagedb progdb +-} + +getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) + -> IndexUtils.IndexState -> Rebuild SourcePackageDb +getSourcePackages verbosity withRepoCtx idxState = do + (sourcePkgDb, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity + repoctx idxState + return (sourcePkgDb, repoContextRepos repoctx) + + monitorFiles . map monitorFile + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDb + + +getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb +getPkgConfigDb verbosity progdb = do + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + mapM_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb + + +-- | Select the config values to monitor for changes package source hashes. +packageLocationsSignature :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature solverPlan = + [ (packageId pkg, packageSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan + ] + + +-- | Get the 'HashValue' for all the source packages where we use hashes, +-- and download any packages required to do so. +-- +-- Note that we don't get hashes for local unpacked packages. +-- +getPackageSourceHashes :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes verbosity withRepoCtx solverPlan = do + + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, packageSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan ] + + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + --TODO: [required eventually] finish remote tarball functionality +-- allRemoteTarballPkgs = +-- [ (pkgid, ) +-- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadata :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + (repoTarballPkgsWithMetadata, + repoTarballPkgsWithoutMetadata) = + partitionEithers + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + (repoTarballPkgsToDownload, + repoTarballPkgsDownloaded) + <- fmap partitionEithers $ + liftIO $ sequence + [ do mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] + + (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do hash <- Sec.trusted <$> -- strip off Trusted tag + Sec.indexLookupHash repoIndex pkgid + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids ] + | (repo, pkgids) <- + map (\grp@((_,repo):_) -> (repo, map fst grp)) + . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload ] + + return (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = localTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- liftIO $ + fmap Map.fromList $ + sequence + [ do srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs ] + + -- Return the combination + return $! hashesFromRepoMetadata + <> hashesFromTarballFiles + + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver SolverSettings{..} + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages pkgStanzasEnable = + + resolveDependencies + platform (compilerInfo comp) + pkgConfigDB solver + resolverParams + + where + + --TODO: [nice to have] disable multiple instances restriction in the solver, but then + -- make sure we can cope with that in the output. + resolverParams = + + setMaxBackjumps solverSettingMaxBackjumps + + --TODO: [required eventually] should only be configurable for custom installs + -- . setIndependentGoals solverSettingIndependentGoals + + . setReorderGoals solverSettingReorderGoals + + . setCountConflicts solverSettingCountConflicts + + --TODO: [required eventually] should only be configurable for custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + --TODO: [required eventually] should only be configurable for custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + + . setSolverVerbosity verbosity + + --TODO: [required eventually] decide if we need to prefer installed for + -- global packages, or prefer latest even for global packages. Perhaps + -- should be configurable but with a different name than "upgrade-dependencies". + . setPreferenceDefault PreferLatestForSelected + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + + . addDefaultSetupDependencies (defaultSetupDeps comp platform + . PD.packageDescription + . packageDescription) + + . addSetupCabalMinVersionConstraint (mkVersion [1,20]) + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- solverSettingPreferences ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- solverSettingConstraints ] + + . addPreferences + -- enable stanza preference where the user did not specify + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = packageName pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Nothing ] + , not (null stanzas) + ] + + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas)) + ConstraintSourceConfigFlagOrTarget + | pkg <- localPackages + , let pkgname = packageName pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Just True ] + , not (null stanzas) + ] + + . addConstraints + --TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] + + . addConstraints + --TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | let flags = solverSettingFlagAssignment + , not (null flags) + , pkg <- localPackages + , let pkgname = packageName pkg ] + + $ stdResolverParams + + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex sourcePkgDb + (map SpecificSourcePackage localPackages) + + +------------------------------------------------------------------------------ +-- * Install plan post-processing +------------------------------------------------------------------------------ + +-- This phase goes from the InstallPlan we get from the solver and has to +-- make an elaborated install plan. +-- +-- We go in two steps: +-- +-- 1. elaborate all the source packages that the solver has chosen. +-- 2. swap source packages for pre-existing installed packages wherever +-- possible. +-- +-- We do it in this order, elaborating and then replacing, because the easiest +-- way to calculate the installed package ids used for the replacement step is +-- from the elaborated configuration for each package. + + + + +------------------------------------------------------------------------------ +-- * Install plan elaboration +------------------------------------------------------------------------------ + +-- Note [SolverId to ConfiguredId] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Dependency solving is a per package affair, so after we're done, we +-- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' +-- and 'solverPkgExeDeps' what packages provide the libraries and executables +-- needed by each component of the package (phew!) For example, if I have +-- +-- library +-- build-depends: lib +-- build-tool-depends: pkg:exe1 +-- build-tools: alex +-- +-- After dependency solving, I find out that this library component has +-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 +-- and alex-0.3 (other components of the package may have different +-- dependencies). Note that I've "lost" the knowledge that I depend +-- *specifically* on the exe1 executable from pkg. +-- +-- So, we have a this graph of packages, and we need to transform it into +-- a graph of components which we are actually going to build. In particular: +-- +-- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) +-- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) +-- +-- In both cases, what was previously a single node/edge may turn into multiple +-- nodes/edges. Multiple components, because there may be multiple components +-- in a package; multiple component deps, because we may depend upon multiple +-- executables from the same package (and maybe, some day, multiple libraries +-- from the same package.) +-- +-- Let's talk about how to do this transformation. Naively, we might consider +-- just processing each package, converting it into (zero or) one or more +-- components. But we also have to update the edges; this leads to +-- two complications: +-- +-- 1. We don't know what the ConfiguredId of a component is until +-- we've configured it, but we cannot configure a component unless +-- we know the ConfiguredId of all its dependencies. Thus, we must +-- process the 'SolverInstallPlan' in topological order. +-- +-- 2. When we process a package, we know the SolverIds of its +-- dependencies, but we have to do some work to turn these into +-- ConfiguredIds. For example, in the case of build-tool-depends, the +-- SolverId isn't enough to uniquely determine the ConfiguredId we should +-- elaborate to: we have to look at the executable name attached to +-- the package name in the package description to figure it out. +-- At the same time, we NEED to use the SolverId, because there might +-- be multiple versions of the same package in the build plan +-- (due to setup dependencies); we can't just look up the package name +-- from the package description. +-- +-- However, we do have the following INVARIANT: a component never directly +-- depends on multiple versions of the same package. Thus, we can +-- adopt the following strategy: +-- +-- * When a package is transformed into components, record +-- a mapping from SolverId to ALL of the components +-- which were elaborated. +-- +-- * When we look up an edge, we use our knowledge of the +-- component name to *filter* the list of components into +-- the ones we actually wanted to refer to. +-- +-- By the way, we can tell that SolverInstallPlan is not the "right" type +-- because a SolverId cannot adequately represent all possible dependency +-- solver states: we may need to record foo-0.1 multiple times in +-- the solver install plan with different dependencies. The solver probably +-- doesn't handle this correctly... but it should. The right way to solve +-- this is to come up with something very much like a 'ConfiguredId', in that +-- it incorporates the version choices of its dependencies, but less +-- fine grained. Fortunately, this doesn't seem to have affected anyone, +-- but it is good to watch out about. + + +-- | Produce an elaborated install plan using the policy for local builds with +-- a nix-style shared store. +-- +-- In theory should be able to make an elaborated install plan with a policy +-- matching that of the classic @cabal install --user@ or @--global@ +-- +elaborateInstallPlan + :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + -> DistDirLayout + -> StoreDirLayout + -> SolverInstallPlan + -> [SourcePackage loc] + -> Map PackageId PackageSourceHash + -> InstallDirs.InstallDirTemplates + -> ProjectConfigShared + -> PackageConfig + -> Map PackageName PackageConfig + -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) +elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB + DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + localPackagesConfig + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) + where + elaboratedSharedConfig = + ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = compilerprogdb + } + + preexistingInstantiatedPkgs = + Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) + where + f (SolverInstallPlan.PreExisting inst) + | let ipkg = instSolverPkgIPI inst + , not (IPI.indefinite ipkg) + = Just (IPI.installedUnitId ipkg, + (FullUnitId (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)))) + f _ = Nothing + + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + + SolverInstallPlan.Configured pkg -> + let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> + quotes (disp (packageId pkg))) $ + map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> LogProgress [ElaboratedConfiguredPackage] + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) + = case mkComponentsGraph (elabEnabledSpec elab0) pd of + Right g -> do + let src_comps = componentsGraphToList g + infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon) + 4 (dispComponentsWithDeps src_comps) + (_, comps) <- mapAccumM buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + let not_per_component_reasons = why_not_per_component src_comps + if null not_per_component_reasons + then return comps + else do checkPerPackageOk comps not_per_component_reasons + return [elaborateSolverToPackage mapDep spkg g $ + comps ++ maybeToList setupComponent] + Left cns -> + dieProgress $ + hang (text "Dependency cycle between the following components:") 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- You are eligible to per-component build if this list is empty + why_not_per_component g + = cuz_custom ++ cuz_spec ++ cuz_length ++ cuz_flag + where + cuz reason = [text reason] + -- At this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + cuz_custom = + case PD.buildType (elabPkgDescription elab0) of + Nothing -> cuz "build-type is not specified" + Just PD.Custom -> cuz "build-type is Custom" + Just _ -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= mkVersion [1,8] = [] + | otherwise = cuz "cabal-version is less than 1.8" + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) + = [] + | otherwise = cuz "you passed --disable-per-component" + + -- | Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CSubLibName _) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." $$ + text "Per-component builds were disabled because" <+> + fsep (punctuate comma reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon mapDep spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) == PD.Custom + = Just elab0 { + elabModuleShape = emptyModuleShape, + elabUnitId = notImpl "elabUnitId", + elabComponentId = notImpl "elabComponentId", + elabLinkedInstantiatedWith = Map.empty, + elabInstallDirs = notImpl "elabInstallDirs", + elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) + } + | otherwise + = Nothing + where + compSolverName = CD.ComponentSetup + compComponentName = Nothing + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + compLibDependencies + = map configuredId dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + compPkgConfigDependencies = [] + + notImpl f = + error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ + f ++ " not implemented yet" + + + buildComponent + :: (ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath) + -> Cabal.Component + -> LogProgress + ((ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath), + ElaboratedConfiguredPackage) + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx (text "In the stanza" <+> + quotes (text (componentNameStanza cname))) $ do + + -- 1. Configure the component, but with a place holder ComponentId. + cc0 <- toConfiguredComponent pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + (Map.unionWith Map.union external_cc_map cc_map) comp + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub (map (annotatedIdToConfiguredId . ci_ann_id) + (cc_includes cc0)) + compExeDependencies = + map annotatedIdToConfiguredId + (cc_exe_deps cc0) + compExeDependencyPaths = + [ (annotatedIdToConfiguredId aid', path) + | aid' <- cc_exe_deps cc0 + , Just path <- [Map.lookup (ann_id aid') exe_map1]] + elab_comp = ElaboratedComponent {..} + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = elab0 { + elabPkgOrComp = ElabComponent $ elab_comp + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly -> + mkComponentId $ + display pkgid ++ "-inplace" ++ + (case Cabal.componentNameString cname of + Nothing -> "" + Just s -> "-" ++ display s) + BuildAndInstall -> + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab1) -- knot tied + cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } + infoProgress $ dispConfiguredComponent cc + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ display def_uid) + lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) cc + infoProgress $ dispLinkedComponent lc + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab = elab1 { + elabModuleShape = lc_shape lc, + elabUnitId = abstractUnitId (lc_uid lc), + elabComponentId = lc_cid lc, + elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), + elabPkgOrComp = ElabComponent $ elab_comp { + compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), + compOrderLibDependencies = + ordNub (map (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc)) + }, + elabInstallDirs = install_dirs cid + } + + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + + return ((cc_map', lc_map', exe_map'), elab) + where + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- NB: compLinkedLibDependencies and + -- compOrderLibDependencies are defined when we define + -- 'elab'. + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + -- TODO: The fact that lib SolverIds and exe SolverIds are + -- jammed together here means that we're losing information! + external_dep_sids = external_lib_dep_sids ++ external_exe_dep_sids + external_dep_pkgs = concatMap mapDep external_dep_sids + + external_exe_map = Map.fromList $ + [ (getComponentId pkg, path) + | pkg <- external_dep_pkgs + , Just path <- [planPackageExePath pkg] ] + exe_map1 = Map.union external_exe_map exe_map + + external_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_dep_pkgs + external_lc_map = Map.fromList (map mkShapeMapping external_dep_pkgs) + + compPkgConfigDependencies = + [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " + ++ display pn ++ " from " + ++ display (elabPkgSourceId elab0)) + (pkgConfigDbPkgVersion pkgConfigDB pn)) + | PkgconfigDependency pn _ <- PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] + + install_dirs cid + | shouldBuildInplaceOnly spkg + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + pkgid + (newSimpleUnitId cid) + (compilerInfo compiler) + InstallDirs.NoCopyDest + platform + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs + storeDirLayout + (compilerId compiler) + cid + + -- NB: For inplace NOT InstallPaths.bindir installDirs; for an + -- inplace build those values are utter nonsense. So we + -- have to guess where the directory is going to be. + -- Fortunately this is "stable" part of Cabal API. + -- But the way we get the build directory is A HORRIBLE + -- HACK. + inplace_bin_dir elab + | shouldBuildInplaceOnly spkg + = distBuildDirectory + (elabDistDirParams elaboratedSharedConfig elab) + "build" case Cabal.componentNameString cname of + Just n -> display n + Nothing -> "" + | otherwise + = InstallDirs.bindir (elabInstallDirs elab) + + -- | Given a 'SolverId' referencing a dependency on a library, return + -- the 'ElaboratedPlanPackage' corresponding to the library. This + -- returns at most one result. + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== CLibName)) . mapDep + + -- | Given an 'ElaboratedPlanPackage', return the path to where the + -- executable that this package represents would be installed. + planPackageExePath :: ElaboratedPlanPackage -> Maybe FilePath + planPackageExePath = + -- Pre-existing executables are assumed to be in PATH + -- already. In fact, this should be impossible. + -- Modest duplication with 'inplace_bin_dir' + InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $ + if elabBuildStyle elab == BuildInplaceOnly + then distBuildDirectory + (elabDistDirParams elaboratedSharedConfig elab) + "build" + case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> display n + _ -> "" + else InstallDirs.bindir (elabInstallDirs elab) + + elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + mapDep + pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) + _flags _stanzas _deps0 _exe_deps0) + compGraph comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab + where + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg + elab = elab0 { + elabUnitId = newSimpleUnitId pkgInstalledId, + elabComponentId = pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, + elabInstallDirs = install_dirs, + elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, + elabModuleShape = modShape + } + + modShape = case find (matchElabPkg (== CLibName)) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg + = mkComponentId (display pkgid ++ "-inplace") + + | otherwise + = assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab) -- recursive use of elab + + | otherwise + = error $ "elaborateInstallPlan: non-inplace package " + ++ " is missing a source hash: " ++ display pkgid + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + filterExt' = filter (isExt . fst) + + pkgLibDependencies + = buildComponentDeps (filterExt . compLibDependencies) + pkgExeDependencies + = buildComponentDeps (filterExt . compExeDependencies) + pkgExeDependencyPaths + = buildComponentDeps (filterExt' . compExeDependencyPaths) + -- TODO: Why is this flat? + pkgPkgConfigDependencies + = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + + pkgDependsOnSelfLib + = CD.fromList [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_closure ] + where + mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] + is_lib CLibName = True + -- NB: this case should not occur, because sub-libraries + -- are not supported without per-component builds + is_lib (CSubLibName _) = True + is_lib _ = False + + buildComponentDeps f + = CD.fromList [ (compSolverName comp, f comp) + | ElaboratedConfiguredPackage{ + elabPkgOrComp = ElabComponent comp + } <- comps + ] + + -- Filled in later + pkgStanzasEnabled = Set.empty + + install_dirs + | shouldBuildInplaceOnly pkg + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + pkgid + (newSimpleUnitId pkgInstalledId) + (compilerInfo compiler) + InstallDirs.NoCopyDest + platform + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have to + -- use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs + storeDirLayout + (compilerId compiler) + pkgInstalledId + + elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon mapDep + pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) + flags stanzas deps0 _exe_deps0) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage {..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabComponentId = error "elaborateSolverToCommon: elabComponentId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" + + elabIsCanonical = True + elabPkgSourceId = pkgid + elabPkgDescription = let Right (desc, _) = + PD.finalizePD + flags elabEnabledSpec (const True) + platform (compilerInfo compiler) + [] gdesc + in desc + elabFlagAssignment = flags + elabFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = Set.fromList stanzas + elabStanzasRequested = + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests + , _ <- PD.testSuites elabPkgDescription ] + ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks + , _ <- PD.benchmarks elabPkgDescription ] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabBuildTargets = [] + elabTestTargets = [] + elabReplTarget = Nothing + elabBuildHaddocks = False + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = if shouldBuildInplaceOnly pkg + then BuildInplaceOnly else BuildAndInstall + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + -- Computing the deps here is a little awful + deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 + elabSetupScriptCliVersion = packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription deps + elabSetupPackageDBStack = buildAndRegisterDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = storePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still + + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + (elabProfExeDetail, + elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix + + + elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption :: (Package pkg, Monoid m) + => pkg -> (PackageConfig -> m) -> m + lookupPerPkgOption pkg f + -- the project config specifies values that apply to packages local to + -- but by default non-local packages get all default config values + -- the project, and can specify per-package values for any package, + | isLocalToProject pkg = local `mappend` perpkg + | otherwise = perpkg + where + local = f localPackagesConfig + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = storePackageDbs + ++ [ distPackageDB (compilerId compiler) ] + + storePackageDbs = storePackageDBStack (compilerId compiler) + + -- For this local build policy, every package that lives in a local source + -- dir (as opposed to a tarball), or depends on such a package, will be + -- built inplace into a shared dist dir. Tarball packages that depend on + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = Set.member (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList + $ map packageId + $ SolverInstallPlan.reverseDependencyClosure + solverPlan + [ PlannedId (packageId pkg) + | pkg <- localPackages ] + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = Set.member (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ] + + pkgsUseSharedLibrary :: Set PackageId + pkgsUseSharedLibrary = + packagesWithLibDepsDownwardClosedProperty needsSharedLib + where + needsSharedLib pkg = + fromMaybe compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + --TODO: [code cleanup] move this into the Cabal lib. It's currently open + -- coded in Distribution.Simple.Configure, but should be made a proper + -- function of the Compiler or CompilerInfo. + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.isDynamic compiler + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = + packagesWithLibDepsDownwardClosedProperty needsProfilingLib + where + needsProfilingLib pkg = + fromFlagOrDefault False (profBothFlag <> profLibFlag) + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = Graph.fromDistinctList $ + map NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = + Set.fromList + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property pkg ] -- just the packages that satisfy the property + --TODO: [nice to have] this does not check the config consistency, + -- e.g. a package explicitly turning off profiling, but something + -- depending on it that needs profiling. This really needs a separate + -- package config validation/resolution pass. + + --TODO: [nice to have] config consistency checking: + -- + profiling libs & exes, exe needs lib, recursive + -- + shared libs & exes, exe needs lib, recursive + -- + vanilla libs & exes, exe needs lib, recursive + -- + ghci or shared lib needed by TH, recursive, ghc version dependent + +-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping + +-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool +matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) + +-- | Get the appropriate 'ComponentName' which identifies an installed +-- component. +ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName +ipiComponentName ipkg = + case IPI.sourceLibName ipkg of + Nothing -> CLibName + Just n -> (CSubLibName n) + +-- | Given a 'ElaboratedConfiguredPackage', report if it matches a +-- 'ComponentName'. +matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool +matchElabPkg p elab = + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any (p . componentName) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' +-- and 'ComponentName' to the 'ComponentId' that that should be used +-- in this case. +mkCCMapping :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping = + InstallPlan.foldPlanPackage + (\ipkg -> (packageName ipkg, + Map.singleton (ipiComponentName ipkg) + -- TODO: libify + (AnnotatedId { + ann_id = IPI.installedComponentId ipkg, + ann_pid = packageId ipkg, + ann_cname = IPI.sourceComponentName ipkg + }))) + $ \elab -> + let mk_aid cn = AnnotatedId { + ann_id = elabComponentId elab, + ann_pid = packageId elab, + ann_cname = cn + } + in (packageName elab, + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Nothing -> Map.empty + Just n -> Map.singleton n (mk_aid n) + ElabPackage _ -> + Map.fromList $ + map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' +-- to the shape of this package, as per mix-in linking. +mkShapeMapping :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping dpkg = + (getComponentId dpkg, (indef_uid, shape)) + where + (dcid, shape) = + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg + indef_uid = + IndefFullUnitId dcid + (Map.fromList [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape)]) + +-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the +-- dependency graph considers only dependencies on libraries which are +-- NOT from setup dependencies. Used to compute the set +-- of packages needed for profiling and dynamic libraries. +newtype NonSetupLibDepSolverPlanPackage + = NonSetupLibDepSolverPlanPackage + { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } + +instance Package NonSetupLibDepSolverPlanPackage where + packageId = packageId . unNonSetupLibDepSolverPlanPackage + +instance IsNode NonSetupLibDepSolverPlanPackage where + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) + = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + +type InstS = Map UnitId ElaboratedPlanPackage +type InstM a = State InstS a + +getComponentId :: ElaboratedPlanPackage + -> ComponentId +getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.Configured elab) = elabComponentId elab +getComponentId (InstallPlan.Installed elab) = elabComponentId elab + +instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan plan = + InstallPlan.new (IndependentGoals False) + (Graph.fromDistinctList (Map.elems ready_map)) + where + pkgs = InstallPlan.toList plan + + cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + + instantiateUnitId :: ComponentId -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = state $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = runState (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName Module + -> InstM ElaboratedPlanPackage + instantiateComponent uid cid insts + | Just planpkg <- Map.lookup cid cmap + = case planpkg of + InstallPlan.Configured (elab@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp }) -> do + deps <- mapM (substUnitId insts) + (compLinkedLibDependencies comp) + let getDep (Module dep_uid _) = [dep_uid] + return $ InstallPlan.Configured elab { + elabUnitId = uid, + elabComponentId = cid, + elabInstantiatedWith = insts, + elabIsCanonical = Map.null insts, + elabPkgOrComp = ElabComponent comp { + compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) ++ + ordNub (map unDefUnitId + (deps ++ concatMap getDep (Map.elems insts))) + } + } + _ -> return planpkg + | otherwise = error ("instantiateComponent: " ++ display cid) + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage + indefiniteComponent _uid cid + | Just planpkg <- Map.lookup cid cmap + = return planpkg + | otherwise = error ("indefiniteComponent: " ++ display cid) + + ready_map = execState work Map.empty + + work = forM_ pkgs $ \pkg -> + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) + -> indefiniteUnitId (elabComponentId elab) + >> return () + _ -> instantiateUnitId (getComponentId pkg) Map.empty + >> return () + +--------------------------- +-- Build targets +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- data ComponentTarget = ... +-- data SubComponentTarget = ... + +-- One step in the build system is to translate higher level intentions like +-- "build this package", "test that package", or "repl that component" into +-- a more detailed specification of exactly which components to build (or other +-- actions like repl or build docs). This translation is somewhat different for +-- different commands. For example "test" for a package will build a different +-- set of components than "build". In addition, the translation of these +-- intentions can fail. For example "run" for a package is only unambiguous +-- when the package has a single executable. +-- +-- So we need a little bit of infrastructure to make it easy for the command +-- implementations to select what component targets are meant when a user asks +-- to do something with a package or component. To do this (and to be able to +-- produce good error messages for mistakes and when targets are not available) +-- we need to gather and summarise accurate information about all the possible +-- targets, both available and unavailable. Then a command implementation can +-- decide which of the available component targets should be selected. + +-- | An available target represents a component within a package that a user +-- command could plausibly refer to. In this sense, all the components defined +-- within the package are things the user could refer to, whether or not it +-- would actually be possible to build that component. +-- +-- In particular the available target contains an 'AvailableTargetStatus' which +-- informs us about whether it's actually possible to select this component to +-- be built, and if not why not. This detail makes it possible for command +-- implementations (like @build@, @test@ etc) to accurately report why a target +-- cannot be used. +-- +-- Note that the type parameter is used to help enforce that command +-- implementations can only select targets that can actually be built (by +-- forcing them to return the @k@ value for the selected targets). +-- In particular 'resolveTargets' makes use of this (with @k@ as +-- @('UnitId', ComponentName')@) to identify the targets thus selected. +-- +data AvailableTarget k = AvailableTarget { + availableTargetPackageId :: PackageId, + availableTargetComponentName :: ComponentName, + availableTargetStatus :: AvailableTargetStatus k, + availableTargetLocalToProject :: Bool + } + deriving (Eq, Show, Functor) + +-- | The status of a an 'AvailableTarget' component. This tells us whether +-- it's actually possible to select this component to be built, and if not +-- why not. +-- +data AvailableTargetStatus k = + TargetDisabledByUser -- ^ When the user does @tests: False@ + | TargetDisabledBySolver -- ^ When the solver could not enable tests + | TargetNotBuildable -- ^ When the component has @buildable: False@ + | TargetNotLocal -- ^ When the component is non-core in a non-local package + | TargetBuildable k TargetRequested -- ^ The target can or should be built + deriving (Eq, Ord, Show, Functor) + +-- | This tells us whether a target ought to be built by default, or only if +-- specifically requested. The policy is that components like libraries and +-- executables are built by default by @build@, but test suites and benchmarks +-- are not, unless this is overridden in the project configuration. +-- +data TargetRequested = + TargetRequestedByDefault -- ^ To be built by default + | TargetNotRequestedByDefault -- ^ Not to be built by default + deriving (Eq, Ord, Show) + +-- | Given the install plan, produce the set of 'AvailableTarget's for each +-- package-component pair. +-- +-- Typically there will only be one such target for each component, but for +-- example if we have a plan with both normal and profiling variants of a +-- component then we would get both as available targets, or similarly if we +-- had a plan that contained two instances of the same version of a package. +-- This approach makes it relatively easy to select all instances\/variants +-- of a component. +-- +availableTargets :: ElaboratedInstallPlan + -> Map (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] +availableTargets installPlan = + let rs = [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + (Map.fromListWith (++) + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, not fake]) + (Map.fromList + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, fake]) + -- The normal targets mask the fake ones. We get all instances of the + -- normal ones and only one copy of the fake ones (as there are many + -- duplicates of the fake ones). See 'availableSourceTargets' below for + -- more details on this fake stuff is about. + +availableInstalledTargets :: IPI.InstalledPackageInfo + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableInstalledTargets ipkg = + let unitid = installedUnitId ipkg + cname = CLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets :: ElaboratedConfiguredPackage + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableSourceTargets elab = + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- map (thus eliminating the duplicates) and then we overlay that map with + -- the normal buildable targets. (This is done above in 'availableTargets'.) + -- + [ (packageId elab, cname, fake, target) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = AvailableTarget { + availableTargetPackageId = packageId elab, + availableTargetComponentName = cname, + availableTargetStatus = status, + availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + + -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + , elabIsCanonical elab + + -- Filter out some bogus parts of the cross product that are never needed + , case status of + TargetBuildable{} | fake -> False + _ -> True + ] + where + isFakeTarget cname = + case elabPkgOrComp elab of + ElabPackage _ -> False + ElabComponent elabComponent -> compComponentName elabComponent + /= Just cname + + componentAvailableTargetStatus + :: Component -> AvailableTargetStatus (UnitId, ComponentName) + componentAvailableTargetStatus component = + case componentOptionalStanza (componentName component) of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case (Map.lookup stanza (elabStanzasRequested elab), + Set.member stanza (elabStanzasAvailable elab)) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error "componentAvailableTargetStatus: impossible" + where + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName -> True + CExeName _ -> True + --TODO: what about sub-libs and foreign libs? + _ -> False + +-- | Merge component targets that overlap each other. Specially when we have +-- multiple targets for the same component and one of them refers to the whole +-- component (rather than a module or file within) then all the other targets +-- for that component are subsumed. +-- +-- We also allow for information associated with each component target, and +-- whenever we targets subsume each other we aggregate their associated info. +-- +nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] +nubComponentTargets = + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map compatSubComponentTargets + where + -- If we're building the whole component then that the only target all we + -- need, otherwise we can have several targets within the component. + wholeComponentOverrides :: [(ComponentTarget, a )] + -> [(ComponentTarget, [a])] + wholeComponentOverrides ts = + case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of + (t:_) -> [ (t, map snd ts) ] + [] -> [ (t,[x]) | (t,x) <- ts ] + + -- Not all Cabal Setup.hs versions support sub-component targets, so switch + -- them over to the whole component + compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) + compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) + | not setupHsSupportsSubComponentTargets + = (ComponentTarget cname WholeComponent, x) + | otherwise = target + + -- Actually the reality is that no current version of Cabal's Setup.hs + -- build command actually support building specific files or modules. + setupHsSupportsSubComponentTargets = False + -- TODO: when that changes, adjust this test, e.g. + -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool +pkgHasEphemeralBuildTargets elab = + isJust (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab + , subtarget /= WholeComponent ] + +-- | The components that we'll build all of, meaning that after they're built +-- we can skip building them again (unlike with building just some modules or +-- other files within a component). +-- +elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage + -> Set ComponentName +elabBuildTargetWholeComponents elab = + Set.fromList + [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + + + +------------------------------------------------------------------------------ +-- * Install plan pruning +------------------------------------------------------------------------------ + +-- | How 'pruneInstallPlanToTargets' should interpret the per-package +-- 'ComponentTarget's: as build, repl or haddock targets. +-- +data TargetAction = TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionHaddock + +-- | Given a set of per-package\/per-component targets, take the subset of the +-- install plan needed to build those targets. Also, update the package config +-- to specify which optional stanzas to enable, and which targets within each +-- package to build. +-- +pruneInstallPlanToTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList + -- We have to do the pruning in two passes + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 + -- Set the targets that will be the roots for pruning + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan + +-- | This is a temporary data type, where we temporarily +-- override the graph dependencies of an 'ElaboratedPackage', +-- so we can take a closure over them. We'll throw out the +-- overriden dependencies when we're done so it's strictly temporary. +-- +-- For 'ElaboratedComponent', this the cached unit IDs always +-- coincide with the real thing. +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] + +instance Package PrunedPackage where + packageId (PrunedPackage elab _) = packageId elab + +instance HasUnitId PrunedPackage where + installedUnitId = nodeKey + +instance IsNode PrunedPackage where + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps + +fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage +fromPrunedPackage (PrunedPackage elab _) = elab + +-- | Set the build targets based on the user targets (but not rev deps yet). +-- This is required before we can prune anything. +-- +setRootTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +setRootTargets targetAction perPkgTargetsMap = + assert (not (Map.null perPkgTargetsMap)) $ + assert (all (not . null) (Map.elems perPkgTargetsMap)) $ + + map (mapConfiguredPackage setElabBuildTargets) + where + -- Set the targets we'll build for this package/component. This is just + -- based on the root targets from the user, not targets implied by reverse + -- dependencies. Those comes in the second pass once we know the rev deps. + -- + setElabBuildTargets elab = + case (Map.lookup (installedUnitId elab) perPkgTargetsMap, + targetAction) of + (Nothing, _) -> elab + (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } + (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } + (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt } + (Just _, TargetActionHaddock) -> elab { elabBuildHaddocks = True } + (Just _, TargetActionRepl) -> + error "pruneInstallPlanToTargets: multiple repl targets" + +-- | Assuming we have previously set the root build targets (i.e. the user +-- targets but not rev deps yet), the first pruning pass does two things: +-- +-- * A first go at determining which optional stanzas (testsuites, benchmarks) +-- are needed. We have a second go in the next pass. +-- * Take the dependency closure using pruned dependencies. We prune deps that +-- are used only by unneeded optional stanzas. These pruned deps are only +-- used for the dependency closure and are not persisted in this pass. +-- +pruneInstallPlanPass1 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 pkgs = + map (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure graph roots) + where + pkgs' = map (mapConfiguredPackage prune) pkgs + graph = Graph.fromDistinctList pkgs' + roots = mapMaybe find_root pkgs' + + prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') + where elab' = pruneOptionalStanzas elab + + find_root (InstallPlan.Configured (PrunedPackage elab _)) = + if not (null (elabBuildTargets elab) + && null (elabTestTargets elab) + && isNothing (elabReplTarget elab) + && not (elabBuildHaddocks elab)) + then Just (installedUnitId elab) + else Nothing + find_root _ = Nothing + + -- Decide whether or not to enable testsuites and benchmarks + -- + -- The testsuite and benchmark targets are somewhat special in that we need + -- to configure the packages with them enabled, and we need to do that even + -- if we only want to build one of several testsuites. + -- + -- There are two cases in which we will enable the testsuites (or + -- benchmarks): if one of the targets is a testsuite, or if all of the + -- testsuite dependencies are already cached in the store. The rationale + -- for the latter is to minimise how often we have to reconfigure due to + -- the particular targets we choose to build. Otherwise choosing to build + -- a testsuite target, and then later choosing to build an exe target + -- would involve unnecessarily reconfiguring the package with testsuites + -- disabled. Technically this introduces a little bit of stateful + -- behaviour to make this "sticky", but it should be benign. + -- + pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + elab { + elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + } + where + stanzas :: Set OptionalStanza + stanzas = optionalStanzasRequiredByTargets elab + <> optionalStanzasRequestedByDefault elab + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + pruneOptionalStanzas elab = elab + + -- Calculate package dependencies but cut out those needed only by + -- optional stanzas that we've determined we will not enable. + -- These pruned deps are not persisted in this pass since they're based on + -- the optional stanzas and we'll make further tweaks to the optional + -- stanzas in the next pass. + -- + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } + = InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } + = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + where + keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas + keepNeeded _ _ = True + stanzas = pkgStanzasEnabled pkg + + optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage + -> Set OptionalStanza + optionalStanzasRequiredByTargets pkg = + Set.fromList + [ stanza + | ComponentTarget cname _ <- elabBuildTargets pkg + ++ elabTestTargets pkg + ++ maybeToList (elabReplTarget pkg) + , stanza <- maybeToList (componentOptionalStanza cname) + ] + + optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage + -> Set OptionalStanza + optionalStanzasRequestedByDefault = + Map.keysSet + . Map.filter (id :: Bool -> Bool) + . elabStanzasRequested + + availablePkgs = + Set.fromList + [ installedUnitId pkg + | InstallPlan.PreExisting pkg <- pkgs ] + +-- | Given a set of already installed packages @availablePkgs@, +-- determine the set of available optional stanzas from @pkg@ +-- which have all of their dependencies already installed. This is used +-- to implement "sticky" testsuites, where once we have installed +-- all of the deps needed for the test suite, we go ahead and +-- enable it always. +optionalStanzasWithDepsAvailable :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> Set OptionalStanza +optionalStanzasWithDepsAvailable availablePkgs elab pkg = + Set.fromList + [ stanza + | stanza <- Set.toList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = CD.select (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] + where + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True + optionalStanzaDeps _ _ = False + + +-- The second pass does three things: +-- +-- * A second go at deciding which optional stanzas to enable. +-- * Prune the dependencies based on the final choice of optional stanzas. +-- * Extend the targets within each package to build, now we know the reverse +-- dependencies, ie we know which libs are needed as deps by other packages. +-- +-- Achieving sticky behaviour with enabling\/disabling optional stanzas is +-- tricky. The first approximation was handled by the first pass above, but +-- it's not quite enough. That pass will enable stanzas if all of the deps +-- of the optional stanza are already installed /in the store/. That's important +-- but it does not account for dependencies that get built inplace as part of +-- the project. We cannot take those inplace build deps into account in the +-- pruning pass however because we don't yet know which ones we're going to +-- build. Once we do know, we can have another go and enable stanzas that have +-- all their deps available. Now we can consider all packages in the pruned +-- plan to be available, including ones we already decided to build from +-- source. +-- +-- Deciding which targets to build depends on knowing which packages have +-- reverse dependencies (ie are needed). This requires the result of first +-- pass, which is another reason we have to split it into two passes. +-- +-- Note that just because we might enable testsuites or benchmarks (in the +-- first or second pass) doesn't mean that we build all (or even any) of them. +-- That depends on which targets we picked in the first pass. +-- +pruneInstallPlanPass2 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 pkgs = + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + where + setStanzasDepsAndTargets elab = + elab { + elabBuildTargets = ordNub + $ elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps, + elabPkgOrComp = + case elabPkgOrComp elab of + ElabPackage pkg -> + let stanzas = pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas + keepNeeded _ _ = True + in ElabPackage $ pkg { + pkgStanzasEnabled = stanzas, + pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), + pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } + r@(ElabComponent _) -> r + } + where + libTargetsRequiredForRevDeps = + [ ComponentTarget Cabal.defaultLibName WholeComponent + | installedUnitId elab `Set.member` hasReverseLibDeps + ] + exeTargetsRequiredForRevDeps = + -- TODO: allow requesting executable with different name + -- than package name + [ ComponentTarget (Cabal.CExeName + $ packageNameToUnqualComponentName + $ packageName $ elabPkgSourceId elab) + WholeComponent + | installedUnitId elab `Set.member` hasReverseExeDeps + ] + + + availablePkgs :: Set UnitId + availablePkgs = Set.fromList (map installedUnitId pkgs) + + hasReverseLibDeps :: Set UnitId + hasReverseLibDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg ] + + hasReverseExeDeps :: Set UnitId + hasReverseExeDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg ] + +mapConfiguredPackage :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage f (InstallPlan.Configured pkg) = + InstallPlan.Configured (f pkg) +mapConfiguredPackage f (InstallPlan.Installed pkg) = + InstallPlan.Installed (f pkg) +mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = + InstallPlan.PreExisting pkg + +componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza +componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas +componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas +componentOptionalStanza _ = Nothing + +------------------------------------ +-- Support for --only-dependencies +-- + +-- | Try to remove the given targets from the install plan. +-- +-- This is not always possible. +-- +pruneInstallPlanToDependencies :: Set UnitId + -> ElaboratedInstallPlan + -> Either CannotPruneDependencies + ElaboratedInstallPlan +pruneInstallPlanToDependencies pkgTargets installPlan = + assert (all (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets)) $ + + fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage + -> Either CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = catMaybes (map lookupDep missingDepIds) + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan + +-- | It is not always possible to prune to only the dependencies of a set of +-- targets. It may be the case that removing a package leaves something else +-- that still needed the pruned package. +-- +-- This lists all the packages that would be broken, and their dependencies +-- that would be missing if we did prune. +-- +newtype CannotPruneDependencies = + CannotPruneDependencies [(ElaboratedPlanPackage, + [ElaboratedPlanPackage])] + deriving (Show) + + +--------------------------- +-- Setup.hs script policy +-- + +-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the +-- solver phase, and part in the elaboration phase. We keep the helper +-- functions for both phases together here so at least you can see all of it +-- in one place. +-- +-- There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. In case 3 we also have +-- to build an external Setup.hs script because the package needs a later +-- Cabal lib version than we can support internally. +-- +-- data SetupScriptStyle = ... -- see ProjectPlanning.Types + +-- | Work out the 'SetupScriptStyle' given the package description. +-- +packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle +packageSetupScriptStyle pkg + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = SetupCustomExplicitDeps + + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = SetupCustomImplicitDeps + + | buildType == PD.Custom + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = SetupCustomImplicitDeps + + | PD.specVersion pkg > cabalVersion -- one cabal-install is built against + = SetupNonCustomExternalLib + + | otherwise + = SetupNonCustomInternalLib + where + buildType = fromMaybe PD.Custom (PD.buildType pkg) + + +-- | Part of our Setup.hs handling policy is implemented by getting the solver +-- to work out setup dependencies for packages. The solver already handles +-- packages that explicitly specify setup dependencies, but we can also tell +-- the solver to treat other packages as if they had setup dependencies. +-- That's what this function does, it gets called by the solver for all +-- packages that don't already have setup dependencies. +-- +-- The dependencies we want to add is different for each 'SetupScriptStyle'. +-- +-- Note that adding default deps means these deps are actually /added/ to the +-- packages that we get out of the solver in the 'SolverInstallPlan'. Making +-- implicit setup deps explicit is a problem in the post-solver stages because +-- we still need to distinguish the case of explicit and implict setup deps. +-- See 'rememberImplicitSetupDeps'. +-- +-- Note in addition to adding default setup deps, we also use +-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require +-- @Cabal >= 1.20@ for Setup scripts. +-- +defaultSetupDeps :: Compiler -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] +defaultSetupDeps compiler platform pkg = + case packageSetupScriptStyle pkg of + + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ + [ Dependency depPkgname anyVersion + | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + [ Dependency cabalPkgname cabalConstraint + | packageName pkg /= cabalPkgname ] + where + -- The Cabal dep is slightly special: + -- * We omit the dep for the Cabal lib itself, since it bootstraps. + -- * We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = orLaterVersion (PD.specVersion pkg) + `intersectVersionRanges` + earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1,25] + + -- For other build types (like Simple) if we still need to compile an + -- external Setup.hs, it'll be one of the simple ones that only depends + -- on Cabal and base. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint + , Dependency basePkgname anyVersion ] + where + cabalConstraint = orLaterVersion (PD.specVersion pkg) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " ++ display (packageId pkg) + + +-- | Work out which version of the Cabal spec we will be using to talk to the +-- Setup.hs interface for this package. +-- +-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result +-- of what the solver picked for us, based on the explicit setup deps or the +-- ones added implicitly by 'defaultSetupDeps'. +-- +packageSetupScriptSpecVersion :: Package pkg + => SetupScriptStyle + -> PD.PackageDescription + -> ComponentDeps [pkg] + -> Version + +-- We're going to be using the internal Cabal library, so the spec version of +-- that is simply the version of the Cabal library that cabal-install has been +-- built with. +packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ = + cabalVersion + +-- If we happen to be building the Cabal lib itself then because that +-- bootstraps itself then we use the version of the lib we're building. +packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ + | packageName pkg == cabalPkgname + = packageVersion pkg + +-- In all other cases we have a look at what version of the Cabal lib the +-- solver picked. Or if it didn't depend on Cabal at all (which is very rare) +-- then we look at the .cabal file to see what spec version it declares. +packageSetupScriptSpecVersion _ pkg deps = + case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of + Just dep -> packageVersion dep + Nothing -> PD.specVersion pkg + + +cabalPkgname, basePkgname :: PackageName +cabalPkgname = mkPackageName "Cabal" +basePkgname = mkPackageName "base" + + +legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] +legacyCustomSetupPkgs compiler (Platform _ os) = + map mkPackageName $ + [ "array", "base", "binary", "bytestring", "containers" + , "deepseq", "directory", "filepath", "old-time", "pretty" + , "process", "time", "transformers" ] + ++ [ "Win32" | os == Windows ] + ++ [ "unix" | os /= Windows ] + ++ [ "ghc-prim" | isGHC ] + ++ [ "template-haskell" | isGHC ] + where + isGHC = compilerCompatFlavor GHC compiler + +-- The other aspects of our Setup.hs policy lives here where we decide on +-- the 'SetupScriptOptions'. +-- +-- Our current policy for the 'SetupCustomImplicitDeps' case is that we +-- try to make the implicit deps cover everything, and we don't allow the +-- compiler to pick up other deps. This may or may not be sustainable, and +-- we might have to allow the deps to be non-exclusive, but that itself would +-- be tricky since we would have to allow the Setup access to all the packages +-- in the store and local dbs. + +setupHsScriptOptions :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions +-- TODO: Fix this so custom is a separate component. Custom can ALWAYS +-- be a separate component!!! +setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + ElaboratedSharedConfig{..} srcdir builddir + isParallelBuild cacheLock = + SetupScriptOptions { + useCabalVersion = thisVersion elabSetupScriptCliVersion, + useCabalSpecVersion = Just elabSetupScriptCliVersion, + useCompiler = Just pkgConfigCompiler, + usePlatform = Just pkgConfigPlatform, + usePackageDB = elabSetupPackageDBStack, + usePackageIndex = Nothing, + useDependencies = [ (uid, srcid) + | ConfiguredId srcid (Just CLibName) uid + <- elabSetupDependencies elab ], + useDependenciesExclusive = True, + useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, + useProgramDb = pkgConfigCompilerProgs, + useDistPref = builddir, + useLoggingHandle = Nothing, -- this gets set later + useWorkingDir = Just srcdir, + useExtraPathEnv = elabExeDependencyPaths elab, + useWin32CleanHack = False, --TODO: [required eventually] + forceExternalSetupMethod = isParallelBuild, + setupCacheLock = Just cacheLock, + isInteractive = False + } + + +-- | To be used for the input for elaborateInstallPlan. +-- +-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. +-- +userInstallDirTemplates :: Compiler + -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates compiler = do + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs StoreDirLayout{storePackageDirectory} + compid ipkgid = + InstallDirs.InstallDirs {..} + where + prefix = storePackageDirectory compid (newSimpleUnitId ipkgid) + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + dynlibdir = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir= "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + + +--TODO: [code cleanup] perhaps reorder this code +-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, +-- make the various Setup.hs {configure,build,copy} flags + + +setupHsConfigureFlags :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity builddir = + sanityCheckElaboratedConfiguredPackage sharedConfig elab + (Cabal.ConfigFlags {..}) + where + configArgs = mempty -- unused, passed via args + configDistPref = toFlag builddir + configCabalFilePath = mempty + configVerbosity = toFlag verbosity + + configInstantiateWith = Map.toList elabInstantiatedWith + + configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag elabComponentId + + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs = Map.toList elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configDynExe = toFlag elabDynExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + configAllowOlder = mempty -- we use configExactConfiguration True + configAllowNewer = mempty -- we use configExactConfiguration True + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = [ (case mb_cn of + -- Special case for internal libraries + Just (CSubLibName uqn) + | packageId elab == srcid + -> mkPackageName (unUnqualComponentName uqn) + _ -> packageName srcid, + cid) + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab ] + configConstraints = + case elabPkgOrComp of + ElabPackage _ -> + [ thisPackageVersion srcid + | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] + ElabComponent _ -> [] + + + -- explicitly clear, then our package db stack + -- TODO: [required eventually] have to do this differently for older Cabal versions + configPackageDBs = Nothing : map Just elabBuildPackageDBStack + + configTests = case elabPkgOrComp of + ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + + configExactConfiguration = toFlag True + configFlagError = mempty --TODO: [research required] appears not to be implemented + configRelocatable = mempty --TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + + +setupHsConfigureArgs :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + where + cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags +setupHsBuildFlags _ _ verbosity builddir = + Cabal.BuildFlags { + buildProgramPaths = mempty, --unused, set at configure time + buildProgramArgs = mempty, --unused, set at configure time + buildVerbosity = toFlag verbosity, + buildDistPref = toFlag builddir, + buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), + buildArgs = mempty -- unused, passed via args not flags + } + + +setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1,17] + = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise + = [] +setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) + = [] + + +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = mempty + , testHumanLog = mempty + , testShowDetails = toFlag Cabal.Always + , testKeepTix = mempty + , testOptions = mempty + } + +setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsTestArgs elab = + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) + +setupHsReplFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags +setupHsReplFlags _ _ verbosity builddir = + Cabal.ReplFlags { + replProgramPaths = mempty, --unused, set at configure time + replProgramArgs = mempty, --unused, set at configure time + replVerbosity = toFlag verbosity, + replDistPref = toFlag builddir, + replReload = mempty --only used as callback from repl + } + + +setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] +setupHsReplArgs elab = + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) + --TODO: should be able to give multiple modules in one component + + +setupHsCopyFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags +setupHsCopyFlags _ _ verbosity builddir destdir = + Cabal.CopyFlags { + copyArgs = [], -- TODO: could use this to only copy what we enabled + copyDest = toFlag (InstallDirs.CopyTo destdir), + copyDistPref = toFlag builddir, + copyVerbosity = toFlag verbosity + } + +setupHsRegisterFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ + verbosity builddir pkgConfFile = + Cabal.RegisterFlags { + regPackageDB = mempty, -- misfeature + regGenScript = mempty, -- never use + regGenPkgConf = toFlag (Just pkgConfFile), + regInPlace = case elabBuildStyle of + BuildInplaceOnly -> toFlag True + _ -> toFlag False, + regPrintId = mempty, -- never use + regDistPref = toFlag builddir, + regArgs = [], + regVerbosity = toFlag verbosity + } + +setupHsHaddockFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags +-- TODO: reconsider whether or not Executables/TestSuites/... +-- needed for component +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.HaddockFlags { + haddockProgramPaths = mempty, --unused, set at configure time + haddockProgramArgs = mempty, --unused, set at configure time + haddockHoogle = toFlag elabHaddockHoogle, + haddockHtml = toFlag elabHaddockHtml, + haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, + haddockForHackage = mempty, --TODO: new flag + haddockForeignLibs = toFlag elabHaddockForeignLibs, + haddockExecutables = toFlag elabHaddockExecutables, + haddockTestSuites = toFlag elabHaddockTestSuites, + haddockBenchmarks = toFlag elabHaddockBenchmarks, + haddockInternal = toFlag elabHaddockInternal, + haddockCss = maybe mempty toFlag elabHaddockCss, + haddockHscolour = toFlag elabHaddockHscolour, + haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, + haddockContents = maybe mempty toFlag elabHaddockContents, + haddockDistPref = toFlag builddir, + haddockKeepTempFiles = mempty, --TODO: from build settings + haddockVerbosity = toFlag verbosity + } + +{- +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = + Cabal.TestFlags { + } +-} + +------------------------------------------------------------------------------ +-- * Sharing installed packages +------------------------------------------------------------------------------ + +-- +-- Nix style store management for tarball packages +-- +-- So here's our strategy: +-- +-- We use a per-user nix-style hashed store, but /only/ for tarball packages. +-- So that includes packages from hackage repos (and other http and local +-- tarballs). For packages in local directories we do not register them into +-- the shared store by default, we just build them locally inplace. +-- +-- The reason we do it like this is that it's easy to make stable hashes for +-- tarball packages, and these packages benefit most from sharing. By contrast +-- unpacked dir packages are harder to hash and they tend to change more +-- frequently so there's less benefit to sharing them. +-- +-- When using the nix store approach we have to run the solver *without* +-- looking at the packages installed in the store, just at the source packages +-- (plus core\/global installed packages). Then we do a post-processing pass +-- to replace configured packages in the plan with pre-existing ones, where +-- possible. Where possible of course means where the nix-style package hash +-- equals one that's already in the store. +-- +-- One extra wrinkle is that unless we know package tarball hashes upfront, we +-- will have to download the tarballs to find their hashes. So we have two +-- options: delay replacing source with pre-existing installed packages until +-- the point during the execution of the install plan where we have the +-- tarball, or try to do as much up-front as possible and then check again +-- during plan execution. The former isn't great because we would end up +-- telling users we're going to re-install loads of packages when in fact we +-- would just share them. It'd be better to give as accurate a prediction as +-- we can. The latter is better for users, but we do still have to check +-- during plan execution because it's important that we don't replace existing +-- installed packages even if they have the same package hash, because we +-- don't guarantee ABI stability. + +-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but +-- not replace installed packages with ghc-pkg. + +packageHashInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@(ElaboratedConfiguredPackage { + elabPkgSourceHash = Just srchash + }) = + PackageHashInputs { + pkgHashPkgId = packageId elab, + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp), + pkgHashSourceHash = srchash, + pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), + pkgHashDirectDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList $ + [ confInstId dep + | dep <- CD.select relevantDeps pkgLibDependencies ] ++ + [ confInstId dep + | dep <- CD.select relevantDeps pkgExeDependencies ] + ElabComponent comp -> + Set.fromList (map confInstId (compLibDependencies comp + ++ compExeDependencies comp)), + pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False + +packageHashInputs _ pkg = + error $ "packageHashInputs: only for packages with source hashes. " + ++ display (packageId pkg) + +packageHashConfigInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs +packageHashConfigInputs + ElaboratedSharedConfig{..} + ElaboratedConfiguredPackage{..} = + + PackageHashConfigInputs { + pkgHashCompilerId = compilerId pkgConfigCompiler, + pkgHashPlatform = pkgConfigPlatform, + pkgHashFlagAssignment = elabFlagAssignment, + pkgHashConfigureScriptArgs = elabConfigureScriptArgs, + pkgHashVanillaLib = elabVanillaLib, + pkgHashSharedLib = elabSharedLib, + pkgHashDynExe = elabDynExe, + pkgHashGHCiLib = elabGHCiLib, + pkgHashProfLib = elabProfLib, + pkgHashProfExe = elabProfExe, + pkgHashProfLibDetail = elabProfLibDetail, + pkgHashProfExeDetail = elabProfExeDetail, + pkgHashCoverage = elabCoverage, + pkgHashOptimization = elabOptimization, + pkgHashSplitObjs = elabSplitObjs, + pkgHashStripLibs = elabStripLibs, + pkgHashStripExes = elabStripExes, + pkgHashDebugInfo = elabDebugInfo, + pkgHashProgramArgs = elabProgramArgs, + pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, + pkgHashExtraIncludeDirs = elabExtraIncludeDirs, + pkgHashProgPrefix = elabProgPrefix, + pkgHashProgSuffix = elabProgSuffix + } + + +-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an +-- 'ElaboratedInstallPlan', replace configured source packages by installed +-- packages from the store whenever they exist. +-- +improveInstallPlanWithInstalledPackages :: Set UnitId + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithInstalledPackages installedPkgIdSet = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved pkg = + installedUnitId pkg `Set.member` installedPkgIdSet + --TODO: sanity checks: + -- * the installed package must have the expected deps etc + -- * the installed package must not be broken, valid dep closure + + --TODO: decide what to do if we encounter broken installed packages, + -- since overwriting is never safe. diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} -- | Types used while planning how to build everything in a project. -- @@ -10,46 +12,69 @@ -- * Elaborated install plan types ElaboratedInstallPlan, ElaboratedConfiguredPackage(..), + + elabDistDirParams, + elabExeDependencyPaths, + elabLibDependencies, + elabOrderLibDependencies, + elabExeDependencies, + elabOrderExeDependencies, + elabSetupDependencies, + elabPkgConfigDependencies, + elabInplaceDependencyBuildCacheFiles, + elabRequiresRegistration, + + elabPlanPackageName, + elabConfiguredName, + elabComponentName, + + ElaboratedPackageOrComponent(..), + ElaboratedComponent(..), + ElaboratedPackage(..), + pkgOrderDependencies, ElaboratedPlanPackage, ElaboratedSharedConfig(..), ElaboratedReadyPackage, BuildStyle(..), CabalFileText, - -- * Types used in executing an install plan - --TODO: [code cleanup] these types should live with execution, not with - -- plan definition. Need to better separate InstallPlan definition. - GenericBuildResult(..), - BuildResult, - BuildSuccess(..), - BuildFailure(..), - DocsResult(..), - TestsResult(..), - -- * Build targets - PackageTarget(..), ComponentTarget(..), + showComponentTarget, + showTestComponentTarget, SubComponentTarget(..), + isTestComponentTarget, + -- * Setup script SetupScriptStyle(..), ) where +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) import Distribution.Client.PackageHash import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan - ( GenericInstallPlan, InstallPlan, GenericPlanPackage ) -import Distribution.Client.ComponentDeps (ComponentDeps) + ( GenericInstallPlan, GenericPlanPackage(..) ) +import Distribution.Client.SolverInstallPlan + ( SolverInstallPlan ) +import Distribution.Client.DistDirLayout +import Distribution.Backpack +import Distribution.Backpack.ModuleShape + +import Distribution.Verbosity +import Distribution.Text +import Distribution.Types.ComponentRequestedSpec import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System import qualified Distribution.PackageDescription as Cabal import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Compiler +import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Program.Db import Distribution.ModuleName (ModuleName) import Distribution.Simple.LocalBuildInfo (ComponentName(..)) @@ -57,23 +82,23 @@ import Distribution.Simple.InstallDirs (PathTemplate) import Distribution.Version +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Utils (ordNub) + import Data.Map (Map) import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Binary import GHC.Generics (Generic) -import Data.Typeable (Typeable) -import Control.Exception +import qualified Data.Monoid as Mon +import Data.Typeable +import Control.Monad --- | The type of install plan produced by the solver and used as the starting --- point for the 'ElaboratedInstallPlan'. --- -type SolverInstallPlan - = InstallPlan --TODO: [code cleanup] redefine locally or move def to solver interface - - -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able -- to execute the plan without having to make further policy decisions. @@ -84,13 +109,21 @@ type ElaboratedInstallPlan = GenericInstallPlan InstalledPackageInfo ElaboratedConfiguredPackage - BuildSuccess BuildFailure type ElaboratedPlanPackage = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - BuildSuccess BuildFailure +-- | User-friendly display string for an 'ElaboratedPlanPackage'. +elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String +elabPlanPackageName verbosity (PreExisting ipkg) + | verbosity <= normal = display (packageName ipkg) + | otherwise = display (installedUnitId ipkg) +elabPlanPackageName verbosity (Configured elab) + = elabConfiguredName verbosity elab +elabPlanPackageName verbosity (Installed elab) + = elabConfiguredName verbosity elab + --TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs @@ -104,136 +137,463 @@ -- used. pkgConfigCompilerProgs :: ProgramDb } - deriving (Show, Generic) + deriving (Show, Generic, Typeable) --TODO: [code cleanup] no Eq instance instance Binary ElaboratedSharedConfig data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { - - pkgInstalledId :: InstalledPackageId, - pkgSourceId :: PackageId, + -- | The 'UnitId' which uniquely identifies this item in a build plan + elabUnitId :: UnitId, - -- | TODO: [code cleanup] we don't need this, just a few bits from it: - -- build type, spec version - pkgDescription :: Cabal.PackageDescription, + elabComponentId :: ComponentId, + elabInstantiatedWith :: Map ModuleName Module, + elabLinkedInstantiatedWith :: Map ModuleName OpenModule, - -- | A total flag assignment for the package - pkgFlagAssignment :: Cabal.FlagAssignment, + -- | This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + elabIsCanonical :: Bool, - -- | The original default flag assignment, used only for reporting. - pkgFlagDefaults :: Cabal.FlagAssignment, + -- | The 'PackageId' of the originating package + elabPkgSourceId :: PackageId, - -- | The exact dependencies (on other plan packages) - -- - pkgDependencies :: ComponentDeps [ConfiguredId], + -- | Shape of the package/component, for Backpack. + elabModuleShape :: ModuleShape, - -- | Which optional stanzas (ie testsuites, benchmarks) can be built. - -- This means the solver produced a plan that has them available. - -- This doesn't necessary mean we build them by default. - pkgStanzasAvailable :: Set OptionalStanza, + -- | A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + elabFlagAssignment :: Cabal.FlagAssignment, - -- | Which optional stanzas the user explicitly asked to enable or - -- to disable. This tells us which ones we build by default, and - -- helps with error messages when the user asks to build something - -- they explicitly disabled. - pkgStanzasRequested :: Map OptionalStanza Bool, + -- | The original default flag assignment, used only for reporting. + elabFlagDefaults :: Cabal.FlagAssignment, - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: Set OptionalStanza, + elabPkgDescription :: Cabal.PackageDescription, -- | Where the package comes from, e.g. tarball, local dir etc. This -- is not the same as where it may be unpacked to for the build. - pkgSourceLocation :: PackageLocation (Maybe FilePath), + elabPkgSourceLocation :: PackageLocation (Maybe FilePath), -- | The hash of the source, e.g. the tarball. We don't have this for -- local source dir packages. - pkgSourceHash :: Maybe PackageSourceHash, + elabPkgSourceHash :: Maybe PackageSourceHash, - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + -- | Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + elabLocalToProject :: Bool, - pkgBuildStyle :: BuildStyle, + -- | Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + elabBuildStyle :: BuildStyle, - pkgSetupPackageDBStack :: PackageDBStack, - pkgBuildPackageDBStack :: PackageDBStack, - pkgRegisterPackageDBStack :: PackageDBStack, + -- | Another way of phrasing 'pkgStanzasAvailable'. + elabEnabledSpec :: ComponentRequestedSpec, - -- | The package contains a library and so must be registered - pkgRequiresRegistration :: Bool, - pkgDescriptionOverride :: Maybe CabalFileText, + -- | Which optional stanzas (ie testsuites, benchmarks) can be built. + -- This means the solver produced a plan that has them available. + -- This doesn't necessary mean we build them by default. + elabStanzasAvailable :: Set OptionalStanza, - pkgVanillaLib :: Bool, - pkgSharedLib :: Bool, - pkgDynExe :: Bool, - pkgGHCiLib :: Bool, - pkgProfLib :: Bool, - pkgProfExe :: Bool, - pkgProfLibDetail :: ProfDetailLevel, - pkgProfExeDetail :: ProfDetailLevel, - pkgCoverage :: Bool, - pkgOptimization :: OptimisationLevel, - pkgSplitObjs :: Bool, - pkgStripLibs :: Bool, - pkgStripExes :: Bool, - pkgDebugInfo :: DebugInfoLevel, + -- | Which optional stanzas the user explicitly asked to enable or + -- to disable. This tells us which ones we build by default, and + -- helps with error messages when the user asks to build something + -- they explicitly disabled. + -- + -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- that a user enabled tests globally, and some local packages + -- just happen not to have any tests. (But perhaps we should + -- warn if ALL local packages don't have any tests.) + elabStanzasRequested :: Map OptionalStanza Bool, - pkgProgramPaths :: Map String FilePath, - pkgProgramArgs :: Map String [String], - pkgProgramPathExtra :: [FilePath], - pkgConfigureScriptArgs :: [String], - pkgExtraLibDirs :: [FilePath], - pkgExtraFrameworkDirs :: [FilePath], - pkgExtraIncludeDirs :: [FilePath], - pkgProgPrefix :: Maybe PathTemplate, - pkgProgSuffix :: Maybe PathTemplate, + elabSetupPackageDBStack :: PackageDBStack, + elabBuildPackageDBStack :: PackageDBStack, + elabRegisterPackageDBStack :: PackageDBStack, - pkgInstallDirs :: InstallDirs.InstallDirs FilePath, + elabPkgDescriptionOverride :: Maybe CabalFileText, - pkgHaddockHoogle :: Bool, - pkgHaddockHtml :: Bool, - pkgHaddockHtmlLocation :: Maybe String, - pkgHaddockExecutables :: Bool, - pkgHaddockTestSuites :: Bool, - pkgHaddockBenchmarks :: Bool, - pkgHaddockInternal :: Bool, - pkgHaddockCss :: Maybe FilePath, - pkgHaddockHscolour :: Bool, - pkgHaddockHscolourCss :: Maybe FilePath, - pkgHaddockContents :: Maybe PathTemplate, + -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool, + elabSharedLib :: Bool, + elabDynExe :: Bool, + elabGHCiLib :: Bool, + elabProfLib :: Bool, + elabProfExe :: Bool, + elabProfLibDetail :: ProfDetailLevel, + elabProfExeDetail :: ProfDetailLevel, + elabCoverage :: Bool, + elabOptimization :: OptimisationLevel, + elabSplitObjs :: Bool, + elabStripLibs :: Bool, + elabStripExes :: Bool, + elabDebugInfo :: DebugInfoLevel, + elabProgramPaths :: Map String FilePath, + elabProgramArgs :: Map String [String], + elabProgramPathExtra :: [FilePath], + elabConfigureScriptArgs :: [String], + elabExtraLibDirs :: [FilePath], + elabExtraFrameworkDirs :: [FilePath], + elabExtraIncludeDirs :: [FilePath], + elabProgPrefix :: Maybe PathTemplate, + elabProgSuffix :: Maybe PathTemplate, + + elabInstallDirs :: InstallDirs.InstallDirs FilePath, + + elabHaddockHoogle :: Bool, + elabHaddockHtml :: Bool, + elabHaddockHtmlLocation :: Maybe String, + elabHaddockForeignLibs :: Bool, + elabHaddockExecutables :: Bool, + elabHaddockTestSuites :: Bool, + elabHaddockBenchmarks :: Bool, + elabHaddockInternal :: Bool, + elabHaddockCss :: Maybe FilePath, + elabHaddockHscolour :: Bool, + elabHaddockHscolourCss :: Maybe FilePath, + elabHaddockContents :: Maybe PathTemplate, + -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs -- script, based on whether it's a build-type Custom, with or without -- explicit deps and the cabal spec version the .cabal file needs. - pkgSetupScriptStyle :: SetupScriptStyle, + elabSetupScriptStyle :: SetupScriptStyle, -- | The version of the Cabal command line interface that we are using -- for this package. This is typically the version of the Cabal lib -- that the Setup.hs is built against. - pkgSetupScriptCliVersion :: Version, + elabSetupScriptCliVersion :: Version, -- Build time related: - pkgBuildTargets :: [ComponentTarget], - pkgReplTarget :: Maybe ComponentTarget, - pkgBuildHaddocks :: Bool - } - deriving (Eq, Show, Generic) + elabBuildTargets :: [ComponentTarget], + elabTestTargets :: [ComponentTarget], + elabReplTarget :: Maybe ComponentTarget, + elabBuildHaddocks :: Bool, -instance Binary ElaboratedConfiguredPackage + --pkgSourceDir ? -- currently passed in later because they can use temp locations + --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + -- | Component/package specific information + elabPkgOrComp :: ElaboratedPackageOrComponent + } + deriving (Eq, Show, Generic, Typeable) + +-- | The package/component contains/is a library and so must be registered +elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool +elabRequiresRegistration elab = + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + build_target || any (depends_on_lib pkg) (elabBuildTargets elab) + where + depends_on_lib pkg (ComponentTarget cn _) = + not (null (CD.select (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg))) + build_target = + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + else Cabal.hasLibs (elabPkgDescription elab) + -- NB: this means we DO NOT reregister if you just built a + -- single file + is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn + is_lib_target _ = False + is_lib CLibName = True + is_lib (CSubLibName _) = True + is_lib _ = False + instance Package ElaboratedConfiguredPackage where - packageId = pkgSourceId + packageId = elabPkgSourceId +instance HasConfiguredId ElaboratedConfiguredPackage where + configuredId elab = + ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) + instance HasUnitId ElaboratedConfiguredPackage where - installedUnitId = pkgInstalledId + installedUnitId = elabUnitId -instance PackageFixedDeps ElaboratedConfiguredPackage where - depends = fmap (map installedPackageId) . pkgDependencies +instance IsNode ElaboratedConfiguredPackage where + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors = elabOrderDependencies +instance Binary ElaboratedConfiguredPackage + +data ElaboratedPackageOrComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackageOrComponent + +elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName +elabComponentName elab = + case elabPkgOrComp elab of + ElabPackage _ -> Just CLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp + +-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. +elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String +elabConfiguredName verbosity elab + | verbosity <= normal + = (case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case compComponentName comp of + Nothing -> "setup from " + Just CLibName -> "" + Just cname -> display cname ++ " from ") + ++ display (packageId elab) + | otherwise + = display (elabUnitId elab) + +elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams +elabDistDirParams shared elab = DistDirParams { + distParamUnitId = installedUnitId elab, + distParamComponentId = elabComponentId elab, + distParamPackageId = elabPkgSourceId elab, + distParamComponentName = case elabPkgOrComp elab of + ElabComponent comp -> compComponentName comp + ElabPackage _ -> Nothing, + distParamCompilerId = compilerId (pkgConfigCompiler shared), + distParamPlatform = pkgConfigPlatform shared, + distParamOptimization = elabOptimization elab + } + +-- | The full set of dependencies which dictate what order we +-- need to build things in the install plan: "order dependencies" +-- balls everything together. This is mostly only useful for +-- ordering; if you are, for example, trying to compute what +-- @--dependency@ flags to pass to a Setup script, you need to +-- use 'elabLibDependencies'. This method is the same as +-- 'nodeNeighbors'. +-- +-- NB: this method DOES include setup deps. +elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderDependencies elab = + case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- libraries. +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage _ -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab) + ElabComponent comp -> compOrderLibDependencies comp + +-- | The library dependencies (i.e., the libraries we depend on, NOT +-- the dependencies of the library), NOT including setup dependencies. +-- These are passed to the @Setup@ script via @--dependency@. +elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) + ElabComponent comp -> compLibDependencies comp + +-- | Like 'elabOrderDependencies', but only returns dependencies on +-- executables. (This coincides with 'elabExeDependencies'.) +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies = + map newSimpleUnitId . elabExeDependencies + +-- | The executable dependencies (i.e., the executables we depend on); +-- these are the executables we must add to the PATH before we invoke +-- the setup script. +elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] +elabExeDependencies elab = map confInstId $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp + +-- | This returns the paths of all the executables we depend on; we +-- must add these paths to PATH before invoking the setup script. +-- (This is usually what you want, not 'elabExeDependencies', if you +-- actually want to build something.) +elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] +elabExeDependencyPaths elab = + case elabPkgOrComp elab of + ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> map snd (compExeDependencyPaths comp) + +-- | The setup dependencies (the library dependencies of the setup executable; +-- note that it is not legal for setup scripts to have executable +-- dependencies at the moment.) +elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabSetupDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] + +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe Version)] +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = pkgPkgConfigDependencies pkg +elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compPkgConfigDependencies comp + +-- | The cache files of all our inplace dependencies which, +-- when updated, require us to rebuild. See #4202 for +-- more details. Essentially, this is a list of filepaths +-- that, if our dependencies get rebuilt, will themselves +-- get updated. +-- +-- Note: the hash of these cache files gets built into +-- the build cache ourselves, which means that we end +-- up tracking transitive dependencies! +-- +-- Note: This tracks the "build" cache file, but not +-- "registration" or "config" cache files. Why not? +-- Arguably we should... +-- +-- Note: This is a bit of a hack, because it is not really +-- the hashes of the SOURCES of our (transitive) dependencies +-- that we should use to decide whether or not to rebuild, +-- but the output BUILD PRODUCTS. The strategy we use +-- here will never work if we want to implement unchanging +-- rebuilds. +elabInplaceDependencyBuildCacheFiles + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] +elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = + go =<< InstallPlan.directDeps plan (nodeKey root_elab) + where + go = InstallPlan.foldPlanPackage (const []) $ \elab -> do + guard (elabBuildStyle elab == BuildInplaceOnly) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + +-- | Some extra metadata associated with an +-- 'ElaboratedConfiguredPackage' which indicates that the "package" +-- in question is actually a single component to be built. Arguably +-- it would be clearer if there were an ADT which branched into +-- package work items and component work items, but I've structured +-- it this way to minimize change to the existing code (which I +-- don't feel qualified to rewrite.) +data ElaboratedComponent + = ElaboratedComponent { + -- | The name of the component to be built according to the solver + compSolverName :: CD.Component, + -- | The name of the component to be built. Nothing if + -- it's a setup dep. + compComponentName :: Maybe ComponentName, + -- | The *external* library dependencies of this component. We + -- pass this to the configure script. + compLibDependencies :: [ConfiguredId], + -- | In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. + compLinkedLibDependencies :: [OpenUnitId], + -- | The executable dependencies of this component (including + -- internal executables). + compExeDependencies :: [ConfiguredId], + -- | The @pkg-config@ dependencies of the component + compPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], + -- | The paths all our executable dependencies will be installed + -- to once they are installed. + compExeDependencyPaths :: [(ConfiguredId, FilePath)], + compOrderLibDependencies :: [UnitId] + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedComponent + +-- | See 'elabOrderDependencies'. +compOrderDependencies :: ElaboratedComponent -> [UnitId] +compOrderDependencies comp = + compOrderLibDependencies comp + ++ compOrderExeDependencies comp + +-- | See 'elabOrderExeDependencies'. +compOrderExeDependencies :: ElaboratedComponent -> [UnitId] +compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies + +data ElaboratedPackage + = ElaboratedPackage { + pkgInstalledId :: InstalledPackageId, + + -- | The exact dependencies (on other plan packages) + -- + pkgLibDependencies :: ComponentDeps [ConfiguredId], + + -- | Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + -- + pkgDependsOnSelfLib :: ComponentDeps [()], + + -- | Dependencies on executable packages. + -- + pkgExeDependencies :: ComponentDeps [ConfiguredId], + + -- | Paths where executable dependencies live. + -- + pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], + + -- | Dependencies on @pkg-config@ packages. + -- NB: this is NOT per-component (although it could be) + -- because Cabal library does not track per-component + -- pkg-config depends; it always does them all at once. + -- + pkgPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], + + -- | Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + pkgStanzasEnabled :: Set OptionalStanza + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackage + +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies pkg = + fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` + fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + -- | This is used in the install plan to indicate how the package will be -- built. -- @@ -261,83 +621,41 @@ type CabalFileText = LBS.ByteString type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage - InstalledPackageInfo ---TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan --- because the same ipkg is used by many packages. So the binary file will be big. --- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo? --- or transform to a shared form when serialising / deserialising -data GenericBuildResult ipkg iresult ifailure - = BuildFailure ifailure - | BuildSuccess (Maybe ipkg) iresult - deriving (Eq, Show, Generic) - -instance (Binary ipkg, Binary iresult, Binary ifailure) => - Binary (GenericBuildResult ipkg iresult ifailure) - -type BuildResult = GenericBuildResult InstalledPackageInfo - BuildSuccess BuildFailure - -data BuildSuccess = BuildOk DocsResult TestsResult - deriving (Eq, Show, Generic) - -data DocsResult = DocsNotTried | DocsFailed | DocsOk - deriving (Eq, Show, Generic) - -data TestsResult = TestsNotTried | TestsOk - deriving (Eq, Show, Generic) - -data BuildFailure = PlanningFailed --TODO: [required eventually] not yet used - | DependentFailed PackageId - | DownloadFailed String --TODO: [required eventually] not yet used - | UnpackFailed String --TODO: [required eventually] not yet used - | ConfigureFailed String - | BuildFailed String - | TestsFailed String --TODO: [required eventually] not yet used - | InstallFailed String - deriving (Eq, Show, Typeable, Generic) - -instance Exception BuildFailure - -instance Binary BuildFailure -instance Binary BuildSuccess -instance Binary DocsResult -instance Binary TestsResult - - --------------------------- -- Build targets -- --- | The various targets within a package. This is more of a high level --- specification than a elaborated prescription. +-- | Specific targets within a package or component to act on e.g. to build, +-- haddock or open a repl. -- -data PackageTarget = - -- | Build the default components in this package. This usually means - -- just the lib and exes, but it can also mean the testsuites and - -- benchmarks if the user explicitly requested them. - BuildDefaultComponents - -- | Build a specific component in this package. - | BuildSpecificComponent ComponentTarget - | ReplDefaultComponent - | ReplSpecificComponent ComponentTarget - | HaddockDefaultComponents - deriving (Eq, Show, Generic) - data ComponentTarget = ComponentTarget ComponentName SubComponentTarget - deriving (Eq, Show, Generic) - -data SubComponentTarget = WholeComponent - | ModuleTarget ModuleName - | FileTarget FilePath - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) -instance Binary PackageTarget instance Binary ComponentTarget -instance Binary SubComponentTarget +-- | Unambiguously render a 'ComponentTarget', e.g., to pass +-- to a Cabal Setup script. +showComponentTarget :: PackageId -> ComponentTarget -> String +showComponentTarget pkgid = + Cabal.showBuildTarget pkgid . toBuildTarget + where + toBuildTarget :: ComponentTarget -> Cabal.BuildTarget + toBuildTarget (ComponentTarget cname subtarget) = + case subtarget of + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname +showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ display n +showTestComponentTarget _ _ = Nothing + +isTestComponentTarget :: ComponentTarget -> Bool +isTestComponentTarget (ComponentTarget (CTestName _) _) = True +isTestComponentTarget _ = False + --------------------------- -- Setup.hs script policy -- @@ -363,7 +681,7 @@ | SetupCustomImplicitDeps | SetupNonCustomExternalLib | SetupNonCustomInternalLib - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs --- a/Distribution/Client/RebuildMonad.hs +++ b/Distribution/Client/RebuildMonad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | An abstraction for re-running actions if values or files have changed. @@ -13,6 +12,7 @@ -- * Rebuild monad Rebuild, runRebuild, + execRebuild, askRoot, -- * Setting up file monitoring @@ -42,8 +42,20 @@ -- * Utils matchFileGlob, + getDirectoryContentsMonitored, + createDirectoryMonitored, + monitorDirectoryStatus, + doesFileExistMonitored, + need, + needIfExists, + findFileWithExtensionMonitored, + findFirstFileMonitored, + findFileMonitored, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.FileMonitor import Distribution.Client.Glob hiding (matchFileGlob) import qualified Distribution.Client.Glob as Glob (matchFileGlob) @@ -51,13 +63,10 @@ import Distribution.Simple.Utils (debug) import Distribution.Verbosity (Verbosity) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Monad.State as State import Control.Monad.Reader as Reader -import Distribution.Compat.Binary (Binary) -import System.FilePath (takeFileName) +import System.FilePath +import System.Directory -- | A monad layered on top of 'IO' to help with re-running actions when the @@ -86,6 +95,10 @@ runRebuild :: FilePath -> Rebuild a -> IO a runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] +-- | Run a 'Rebuild' IO action. +execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] +execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] + -- | The root that relative paths are interpreted as being relative to. askRoot :: Rebuild FilePath askRoot = Rebuild Reader.ask @@ -145,3 +158,80 @@ monitorFiles [monitorFileGlobExistence glob] liftIO $ Glob.matchFileGlob root glob +getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] +getDirectoryContentsMonitored dir = do + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ getDirectoryContents dir + else return [] + +createDirectoryMonitored :: Bool -> FilePath -> Rebuild () +createDirectoryMonitored createParents dir = do + monitorFiles [monitorDirectoryExistence dir] + liftIO $ createDirectoryIfMissing createParents dir + +-- | Monitor a directory as in 'monitorDirectory' if it currently exists or +-- as 'monitorNonExistentDirectory' if it does not. +monitorDirectoryStatus :: FilePath -> Rebuild Bool +monitorDirectoryStatus dir = do + exists <- liftIO $ doesDirectoryExist dir + monitorFiles [if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir] + return exists + +-- | Like 'doesFileExist', but in the 'Rebuild' monad. This does +-- NOT track the contents of 'FilePath'; use 'need' in that case. +doesFileExistMonitored :: FilePath -> Rebuild Bool +doesFileExistMonitored f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileExistence f + else monitorNonExistentFile f] + return exists + +-- | Monitor a single file +need :: FilePath -> Rebuild () +need f = monitorFiles [monitorFileHashed f] + +-- | Monitor a file if it exists; otherwise check for when it +-- gets created. This is a bit better for recompilation avoidance +-- because sometimes users give bad package metadata, and we don't +-- want to repeatedly rebuild in this case (which we would if we +-- need'ed a non-existent file). +needIfExists :: FilePath -> Rebuild () +needIfExists f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileHashed f + else monitorNonExistentFile f] + +-- | Like 'findFileWithExtension', but in the 'Rebuild' monad. +findFileWithExtensionMonitored + :: [String] + -> [FilePath] + -> FilePath + -> Rebuild (Maybe FilePath) +findFileWithExtensionMonitored extensions searchPath baseName = + findFirstFileMonitored id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFirstFile', but in the 'Rebuild' monad. +findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a) +findFirstFileMonitored file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Like 'findFile', but in the 'Rebuild' monad. +findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) +findFileMonitored searchPath fileName = + findFirstFileMonitored id + [ path fileName + | path <- nub searchPath] diff --git a/Distribution/Client/Reconfigure.hs b/Distribution/Client/Reconfigure.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Reconfigure.hs @@ -0,0 +1,235 @@ +module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where + +import Control.Monad ( unless, when ) +import Data.Maybe ( isJust ) +import Data.Monoid hiding ( (<>) ) +import System.Directory ( doesFileExist ) + +import Distribution.Compat.Semigroup + +import Distribution.Verbosity + +import Distribution.Simple.Configure ( localBuildInfoFile ) +import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag ) +import Distribution.Simple.Utils + ( existsAndIsMoreRecentThan, defaultPackageDesc, info ) + +import Distribution.Client.Config ( SavedConfig(..) ) +import Distribution.Client.Configure ( readConfigFlags ) +import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) +import Distribution.Client.Sandbox + ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath + , maybeReinstallAddSourceDeps, updateInstallDirs ) +import Distribution.Client.Sandbox.PackageEnvironment + ( userPackageEnvironmentFile ) +import Distribution.Client.Sandbox.Types ( UseSandbox(..) ) +import Distribution.Client.Setup + ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) + , SkipAddSourceDepsCheck(..) ) + + +-- | @Check@ represents a function to check some condition on type @a@. The +-- returned 'Any' is 'True' if any part of the condition failed. +newtype Check a = Check { + runCheck :: Any -- ^ Did any previous check fail? + -> a -- ^ value returned by previous checks + -> IO (Any, a) -- ^ Did this check fail? What value is returned? +} + +instance Semigroup (Check a) where + (<>) c d = Check $ \any0 a0 -> do + (any1, a1) <- runCheck c any0 a0 + (any2, a2) <- runCheck d (any0 <> any1) a1 + return (any0 <> any1 <> any2, a2) + +instance Monoid (Check a) where + mempty = Check $ \_ a -> return (mempty, a) + mappend = (<>) + + +-- | Re-configure the package in the current directory if needed. Deciding +-- when to reconfigure and with which options is convoluted: +-- +-- If we are reconfiguring, we must always run @configure@ with the +-- verbosity option we are given; however, that a previous configuration +-- uses a different verbosity setting is not reason enough to reconfigure. +-- +-- The package should be configured to use the same \"dist\" prefix as +-- given to the @build@ command, otherwise the build will probably +-- fail. Not only does this determine the \"dist\" prefix setting if we +-- need to reconfigure anyway, but an existing configuration should be +-- invalidated if its \"dist\" prefix differs. +-- +-- If the package has never been configured (i.e., there is no +-- LocalBuildInfo), we must configure first, using the default options. +-- +-- If the package has been configured, there will be a 'LocalBuildInfo'. +-- If there no package description file, we assume that the +-- 'PackageDescription' is up to date, though the configuration may need +-- to be updated for other reasons (see above). If there is a package +-- description file, and it has been modified since the 'LocalBuildInfo' +-- was generated, then we need to reconfigure. +-- +-- The caller of this function may also have specific requirements +-- regarding the flags the last configuration used. For example, +-- 'testAction' requires that the package be configured with test suites +-- enabled. The caller may pass the required settings to this function +-- along with a function to check the validity of the saved 'ConfigFlags'; +-- these required settings will be checked first upon determining that +-- a previous configuration exists. +reconfigure + :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ()) + -- ^ configure action + -> Verbosity + -- ^ Verbosity setting + -> FilePath + -- ^ \"dist\" prefix + -> UseSandbox + -> SkipAddSourceDepsCheck + -- ^ Should we skip the timestamp check for modified + -- add-source dependencies? + -> Flag (Maybe Int) + -- ^ -j flag for reinstalling add-source deps. + -> Check (ConfigFlags, ConfigExFlags) + -- ^ Check that the required flags are set. + -- If they are not set, provide a message explaining the + -- reason for reconfiguration. + -> [String] -- ^ Extra arguments + -> GlobalFlags -- ^ Global flags + -> SavedConfig + -> IO SavedConfig +reconfigure + configureAction + verbosity + dist + useSandbox + skipAddSourceDepsCheck + numJobsFlag + check + extraArgs + globalFlags + config + = do + + savedFlags@(_, _) <- readConfigFlags dist + + useNix <- fmap isJust (findNixExpr globalFlags config) + alreadyInNixShell <- inNixShell + + if useNix && not alreadyInNixShell + then do + + -- If we are using Nix, we must reinstantiate the derivation outside + -- the shell. Eventually, the caller will invoke 'nixShell' which will + -- rerun cabal inside the shell. That will bring us back to 'reconfigure', + -- but inside the shell we'll take the second branch, below. + + -- This seems to have a problem: won't 'configureAction' call 'nixShell' + -- yet again, spawning an infinite tree of subprocesses? + -- No, because 'nixShell' doesn't spawn a new process if it is already + -- running in a Nix shell. + + nixInstantiate verbosity dist False globalFlags config + return config + + else do + + let checks = + checkVerb + <> checkDist + <> checkOutdated + <> check + <> checkAddSourceDeps + (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + + let (_, config') = + updateInstallDirs + (configUserInstall configFlags) + (useSandbox, config) + + when force $ configureAction flags extraArgs globalFlags + return config' + + where + + -- Changing the verbosity does not require reconfiguration, but the new + -- verbosity should be used if reconfiguring. + checkVerb = Check $ \_ (configFlags, configExFlags) -> do + let configFlags' = configFlags { configVerbosity = toFlag verbosity} + return (mempty, (configFlags', configExFlags)) + + -- Reconfiguration is required if @--build-dir@ changes. + checkDist = Check $ \_ (configFlags, configExFlags) -> do + -- Always set the chosen @--build-dir@ before saving the flags, + -- or bad things could happen. + savedDist <- findSavedDistPref config (configDistPref configFlags) + let distChanged = dist /= savedDist + when distChanged $ info verbosity "build directory changed" + let configFlags' = configFlags { configDistPref = toFlag dist } + return (Any distChanged, (configFlags', configExFlags)) + + checkOutdated = Check $ \_ flags@(configFlags, _) -> do + let buildConfig = localBuildInfoFile dist + + -- Has the package ever been configured? If not, reconfiguration is + -- required. + configured <- doesFileExist buildConfig + unless configured $ info verbosity "package has never been configured" + + -- Is the configuration older than the sandbox configuration file? + -- If so, reconfiguration is required. + sandboxConfig <- getSandboxConfigFilePath globalFlags + sandboxConfigNewer <- existsAndIsMoreRecentThan sandboxConfig buildConfig + when sandboxConfigNewer $ + info verbosity "sandbox was created after the package was configured" + + -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need + -- to force reconfigure. Note that it's possible to use @cabal.config@ + -- even without sandboxes. + userPackageEnvironmentFileModified <- + existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig + when userPackageEnvironmentFileModified $ + info verbosity ("user package environment file ('" + ++ userPackageEnvironmentFile ++ "') was modified") + + -- Is the configuration older than the package description? + descrFile <- maybe (defaultPackageDesc verbosity) return + (flagToMaybe (configCabalFilePath configFlags)) + outdated <- existsAndIsMoreRecentThan descrFile buildConfig + when outdated $ info verbosity (descrFile ++ " was changed") + + let failed = + Any outdated + <> Any userPackageEnvironmentFileModified + <> Any sandboxConfigNewer + <> Any (not configured) + return (failed, flags) + + checkAddSourceDeps = Check $ \(Any force') flags@(configFlags, _) -> do + let (_, config') = + updateInstallDirs + (configUserInstall configFlags) + (useSandbox, config) + + skipAddSourceDepsCheck' + | force' = SkipAddSourceDepsCheck + | otherwise = skipAddSourceDepsCheck + + when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $ + info verbosity "skipping add-source deps check" + + -- Were any add-source dependencies reinstalled in the sandbox? + depsReinstalled <- + case skipAddSourceDepsCheck' of + DontSkipAddSourceDepsCheck -> + maybeReinstallAddSourceDeps + verbosity numJobsFlag configFlags globalFlags + (useSandbox, config') + SkipAddSourceDepsCheck -> do + return NoDepsReinstalled + + case depsReinstalled of + NoDepsReinstalled -> return (mempty, flags) + ReinstalledSomeDeps -> do + info verbosity "some add-source dependencies were reinstalled" + return (Any True, flags) diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs --- a/Distribution/Client/Run.hs +++ b/Distribution/Client/Run.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Run @@ -11,8 +10,15 @@ module Distribution.Client.Run ( run, splitRunArgs ) where +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.TargetInfo (targetCLBI) +import Distribution.Types.LocalBuildInfo (componentNameTargets') + import Distribution.Client.Utils (tryCanonicalizePath) +import Distribution.Types.UnqualComponentName import Distribution.PackageDescription (Executable (..), TestSuite(..), Benchmark(..), @@ -23,21 +29,16 @@ import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.LocalBuildInfo (ComponentName (..), LocalBuildInfo (..), - getComponentLocalBuildInfo, depLibraryPaths) -import Distribution.Simple.Utils (die, notice, warn, +import Distribution.Simple.Utils (die', notice, warn, rawSystemExitWithEnv, addLibraryPath) import Distribution.System (Platform (..)) import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) import qualified Distribution.Simple.GHCJS as GHCJS -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$>)) -#endif -import Data.List (find) -import Data.Foldable (traverse_) import System.Directory (getCurrentDirectory) import Distribution.Compat.Environment (getEnvironment) import System.FilePath ((<.>), ()) @@ -51,7 +52,7 @@ case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) Left err -> do warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. - die err + die' verbosity err Right (True, exe, xs) -> return (exe, xs) Right (False, exe, xs) -> do let addition = " Interpreting all parameters to `run` as a parameter to" @@ -70,14 +71,14 @@ ([] , _) -> Left "Couldn't find any enabled executables." ([exe], []) -> return (False, exe, []) ([exe], (x:xs)) - | x == exeName exe -> return (True, exe, xs) - | otherwise -> return (False, exe, args) - (_ , []) -> Left + | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs) + | otherwise -> return (False, exe, args) + (_ , []) -> Left $ "This package contains multiple executables. " ++ "You must pass the executable name as the first argument " ++ "to 'cabal run'." (_ , (x:xs)) -> - case find (\exe -> exeName exe == x) enabledExes of + case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of Nothing -> Left $ "No executable named '" ++ x ++ "'." Just exe -> return (True, exe, xs) where @@ -86,20 +87,20 @@ maybeWarning :: Maybe String maybeWarning = case args of [] -> Nothing - (x:_) -> lookup x components + (x:_) -> lookup (mkUnqualComponentName x) components where - components :: [(String, String)] -- Component name, message. + components :: [(UnqualComponentName, String)] -- Component name, message. components = - [ (name, "The executable '" ++ name ++ "' is disabled.") + [ (name, "The executable '" ++ display name ++ "' is disabled.") | e <- executables pkg_descr , not . buildable . buildInfo $ e, let name = exeName e] - ++ [ (name, "There is a test-suite '" ++ name ++ "'," + ++ [ (name, "There is a test-suite '" ++ display name ++ "'," ++ " but the `run` command is only for executables.") | t <- testSuites pkg_descr , let name = testName t] - ++ [ (name, "There is a benchmark '" ++ name ++ "'," + ++ [ (name, "There is a benchmark '" ++ display name ++ "'," ++ " but the `run` command is only for executables.") | b <- benchmarks pkg_descr , let name = benchmarkName b] @@ -114,26 +115,29 @@ curDir dataDir pkg_descr) (path, runArgs) <- - case compilerFlavor (compiler lbi) of + let exeName' = display $ exeName exe + in case compilerFlavor (compiler lbi) of GHCJS -> do let (script, cmd, cmdArgs) = GHCJS.runCmd (withPrograms lbi) - (buildPref exeName exe exeName exe) + (buildPref exeName' exeName') script' <- tryCanonicalizePath script return (cmd, cmdArgs ++ [script']) _ -> do p <- tryCanonicalizePath $ - buildPref exeName exe (exeName exe <.> exeExtension) + buildPref exeName' (exeName' <.> exeExtension) return (p, []) env <- (dataDirEnvVar:) <$> getEnvironment -- Add (DY)LD_LIBRARY_PATH if needed env' <- if withDynExe lbi then do let (Platform _ os) = hostPlatform lbi - clbi = getComponentLocalBuildInfo lbi - (CExeName (exeName exe)) + clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of + [target] -> return (targetCLBI target) + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" paths <- depLibraryPaths True False lbi clbi return (addLibraryPath os paths env) else return env - notice verbosity $ "Running " ++ exeName exe ++ "..." + notice verbosity $ "Running " ++ display (exeName exe) ++ "..." rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox @@ -38,12 +39,16 @@ updateSandboxConfigFileFlag, updateInstallDirs, - configPackageDB', configCompilerAux', getPersistOrConfigCompiler + getPersistOrConfigCompiler ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) - , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags + , GlobalFlags(..), configCompilerAux', configPackageDB' + , defaultConfigExFlags, defaultInstallFlags , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps , maybeAddCompilerTimestampRecord @@ -70,59 +75,55 @@ , UseSandbox(..) ) import Distribution.Client.SetupWrapper ( SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Types ( PackageLocation(..) - , SourcePackage(..) ) +import Distribution.Client.Types ( PackageLocation(..) ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.PackageDescription.Parse ( readPackageDescription ) -import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) - , PackageDBStack ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) +#else +import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) +#endif +import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure ( configCompilerAuxEx - , interpretPackageDbFlags , getPackageDBContents , maybeGetPersistBuildConfig , findDistPrefOrDefault , findDistPref ) import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess ( knownSuffixHandlers ) -import Distribution.Simple.Program ( ProgramConfiguration ) +import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) -import Distribution.Simple.Utils ( die, debug, notice, info, warn +import Distribution.Simple.Utils ( die', debug, notice, info, warn , debugNoWrap, defaultPackageDesc - , intercalate, topHandlerWith + , topHandlerWith , createDirectoryIfMissingVerbose ) import Distribution.Package ( Package(..) ) import Distribution.System ( Platform ) import Distribution.Text ( display ) -import Distribution.Verbosity ( Verbosity, lessVerbose ) +import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Environment ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Simple.Register as Register + +import Distribution.Solver.Types.SourcePackage + import qualified Data.Map as M import qualified Data.Set as S import Data.Either (partitionEithers) import Control.Exception ( assert, bracket_ ) -import Control.Monad ( forM, liftM, liftM2, unless, when ) +import Control.Monad ( forM, mapM, mapM_ ) import Data.Bits ( shiftL, shiftR, xor ) -import Data.Char ( ord ) import Data.IORef ( newIORef, writeIORef, readIORef ) import Data.List ( delete - , foldl' - , intersperse - , isPrefixOf , groupBy ) import Data.Maybe ( fromJust ) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( mempty, mappend ) -#endif -import Data.Word ( Word32 ) import Numeric ( showHex ) import System.Directory ( canonicalizePath , createDirectory @@ -210,16 +211,16 @@ (globalConfigFile globalFlags) -- | Return the name of the package index file for this package environment. -tryGetIndexFilePath :: SavedConfig -> IO FilePath -tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config) +tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath +tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'. -tryGetIndexFilePath' :: GlobalFlags -> IO FilePath -tryGetIndexFilePath' globalFlags = do +tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath +tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags case paths of - [] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration _ -> return $ (last paths) Index.defaultIndexFileName where @@ -228,19 +229,19 @@ -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error -- message than just pattern-matching. -getSandboxPackageDB :: ConfigFlags -> IO PackageDB -getSandboxPackageDB configFlags = do +getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB +getSandboxPackageDB verbosity configFlags = do case configPackageDBs configFlags of [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? [] -> - die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt + die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt [_] -> - die $ "Unexpected contents of the 'package-db' field. " + die' verbosity $ "Unexpected contents of the 'package-db' field. " ++ sandboxConfigCorrupt _ -> - die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt + die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt where sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." @@ -248,11 +249,11 @@ -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags - -> Compiler -> ProgramConfiguration + -> Compiler -> ProgramDb -> IO InstalledPackageIndex -getInstalledPackagesInSandbox verbosity configFlags comp conf = do - sandboxDB <- getSandboxPackageDB configFlags - getPackageDBContents verbosity comp sandboxDB conf +getInstalledPackagesInSandbox verbosity configFlags comp progdb = do + sandboxDB <- getSandboxPackageDB verbosity configFlags + getPackageDBContents verbosity comp sandboxDB progdb -- | Temporarily add $SANDBOX_DIR/bin to $PATH. withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a @@ -280,13 +281,13 @@ -- | Initialise a package DB for this compiler if it doesn't exist. initPackageDBIfNeeded :: Verbosity -> ConfigFlags - -> Compiler -> ProgramConfiguration + -> Compiler -> ProgramDb -> IO () -initPackageDBIfNeeded verbosity configFlags comp conf = do - SpecificPackageDB dbPath <- getSandboxPackageDB configFlags +initPackageDBIfNeeded verbosity configFlags comp progdb = do + SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags packageDBExists <- doesDirectoryExist dbPath unless packageDBExists $ - Register.initPackageDB verbosity comp conf dbPath + Register.initPackageDB verbosity comp progdb dbPath when packageDBExists $ debug verbosity $ "The package database already exists: " ++ dbPath @@ -318,7 +319,7 @@ -- Determine which compiler to use (using the value from ~/.cabal/config). userConfig <- loadConfig verbosity (globalConfigFile globalFlags) - (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig) + (comp, platform, progdb) <- configCompilerAuxEx (savedConfigureFlags userConfig) -- Create the package environment file. pkgEnvFile <- getSandboxConfigFilePath globalFlags @@ -328,7 +329,7 @@ configFlags = savedConfigureFlags config -- Create the index file if it doesn't exist. - indexFile <- tryGetIndexFilePath config + indexFile <- tryGetIndexFilePath verbosity config indexFileExists <- doesFileExist indexFile if indexFileExists then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir @@ -336,7 +337,7 @@ Index.createEmpty verbosity indexFile -- Create the package DB for the default compiler. - initPackageDBIfNeeded verbosity configFlags comp conf + initPackageDBIfNeeded verbosity configFlags comp progdb maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform @@ -367,7 +368,7 @@ curDir defaultSandboxLocation when isNonDefaultSandboxLocation $ - die $ "Non-default sandbox location used: '" ++ sandboxDir + die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir ++ "'.\nAssuming a shared sandbox. Please delete '" ++ sandboxDir ++ "' manually." @@ -399,7 +400,7 @@ -> IO () doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do let savedConfig = pkgEnvSavedConfig pkgEnv - indexFile <- tryGetIndexFilePath savedConfig + indexFile <- tryGetIndexFilePath verbosity savedConfig -- If we're running 'sandbox add-source' for the first time for this compiler, -- we need to create an initial timestamp record. @@ -407,7 +408,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform - withAddTimestamps sandboxDir $ do + withAddTimestamps verbosity sandboxDir $ do -- Path canonicalisation is done in addBuildTreeRefs, but we do it -- twice because of the timestamps file. buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs @@ -440,7 +441,7 @@ pkgs <- forM buildTreeRefs $ \buildTreeRef -> inDir (Just buildTreeRef) $ return . flattenPackageDescription - =<< readPackageDescription verbosity + =<< readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If @@ -474,7 +475,7 @@ -> IO () sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) (results, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs @@ -483,7 +484,7 @@ removedRefs = fmap convDict removedPaths unless (null removedPaths) $ do - removeTimestamps sandboxDir removedPaths + removeTimestamps verbosity sandboxDir removedPaths notice verbosity $ "Success deleting sources: " ++ showL removedRefs ++ "\n\n" @@ -491,7 +492,7 @@ unless (null failedPaths) $ do let groupedFailures = groupBy errorType failedPaths mapM_ handleErrors groupedFailures - die $ "The sources with the above errors were skipped. (" ++ + die' verbosity $ "The sources with the above errors were skipped. (" ++ showL (fmap getPath failedPaths) ++ ")" notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ @@ -529,7 +530,7 @@ -> IO () sandboxListSources verbosity _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) refs <- Index.listBuildTreeRefs verbosity Index.ListIgnored Index.LinksAndSnapshots indexFile @@ -551,10 +552,10 @@ let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv -- Invoke hc-pkg for the most recently configured compiler (if any), -- using the right package-db for the compiler (see #1935). - (comp, platform, conf) <- getPersistOrConfigCompiler configFlags + (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags let dir = sandboxPackageDBPath sandboxDir comp platform dbStack = [GlobalPackageDB, SpecificPackageDB dir] - Register.invokeHcPkg verbosity comp conf dbStack extraArgs + Register.invokeHcPkg verbosity comp progdb dbStack extraArgs updateInstallDirs :: Flag Bool -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig) @@ -596,7 +597,7 @@ -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present. SandboxPackageEnvironment -> do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - -- ^ Prints an error message and exits on error. + -- Prints an error message and exits on error. let config = pkgEnvSavedConfig pkgEnv return (UseSandbox sandboxDir, config) @@ -635,7 +636,7 @@ flag = (globalRequireSandbox . savedGlobalFlags $ config) `mappend` (globalRequireSandbox globalFlags) checkFlag (Flag True) = - die $ "'require-sandbox' is set to True, but no sandbox is present. " + die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. " ++ "Use '--no-require-sandbox' if you want to override " ++ "'require-sandbox' temporarily." checkFlag (Flag False) = return () @@ -673,37 +674,37 @@ { configDistPref = Flag sandboxDistPref } haddockFlags = mempty { haddockDistPref = Flag sandboxDistPref } - (comp, platform, conf) <- configCompilerAux' configFlags - retVal <- newIORef NoDepsReinstalled + (comp, platform, progdb) <- configCompilerAux' configFlags + retVal <- newIORef NoDepsReinstalled withSandboxPackageInfo verbosity configFlags globalFlags - comp platform conf sandboxDir $ \sandboxPkgInfo -> + comp platform progdb sandboxDir $ \sandboxPkgInfo -> unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do - withRepoContext verbosity globalFlags $ \repoContext -> do - let args :: InstallArgs - args = ((configPackageDB' configFlags) - ,repoContext - ,comp, platform, conf - ,UseSandbox sandboxDir, Just sandboxPkgInfo - ,globalFlags, configFlags, configExFlags, installFlags - ,haddockFlags) + withRepoContext verbosity globalFlags $ \repoContext -> do + let args :: InstallArgs + args = ((configPackageDB' configFlags) + ,repoContext + ,comp, platform, progdb + ,UseSandbox sandboxDir, Just sandboxPkgInfo + ,globalFlags, configFlags, configExFlags, installFlags + ,haddockFlags) - -- This can actually be replaced by a call to 'install', but we use a - -- lower-level API because of layer separation reasons. Additionally, we - -- might want to use some lower-level features this in the future. - withSandboxBinDirOnSearchPath sandboxDir $ do - installContext <- makeInstallContext verbosity args Nothing - installPlan <- foldProgress logMsg die' return =<< - makeInstallPlan verbosity args installContext + -- This can actually be replaced by a call to 'install', but we use a + -- lower-level API because of layer separation reasons. Additionally, we + -- might want to use some lower-level features this in the future. + withSandboxBinDirOnSearchPath sandboxDir $ do + installContext <- makeInstallContext verbosity args Nothing + installPlan <- foldProgress logMsg die'' return =<< + makeInstallPlan verbosity args installContext - processInstallPlan verbosity args installContext installPlan - writeIORef retVal ReinstalledSomeDeps + processInstallPlan verbosity args installContext installPlan + writeIORef retVal ReinstalledSomeDeps readIORef retVal where - die' message = die (message ++ installFailedInSandbox) + die'' message = die' verbosity (message ++ installFailedInSandbox) -- TODO: use a better error message, remove duplication. installFailedInSandbox = "Note: when using a sandbox, all packages are required to have " @@ -721,25 +722,25 @@ -- we don't update the timestamp file here - this is done in -- 'postInstallActions'. withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags - -> Compiler -> Platform -> ProgramConfiguration + -> Compiler -> Platform -> ProgramDb -> FilePath -> (SandboxPackageInfo -> IO ()) -> IO () withSandboxPackageInfo verbosity configFlags globalFlags - comp platform conf sandboxDir cont = do + comp platform progdb sandboxDir cont = do -- List all add-source deps. - indexFile <- tryGetIndexFilePath' globalFlags + indexFile <- tryGetIndexFilePath' verbosity globalFlags buildTreeRefs <- Index.listBuildTreeRefs verbosity Index.DontListIgnored Index.OnlyLinks indexFile let allAddSourceDepsSet = S.fromList buildTreeRefs -- List all packages installed in the sandbox. installedPkgIndex <- getInstalledPackagesInSandbox verbosity - configFlags comp conf + configFlags comp progdb let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. - depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs - depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles + depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs + depsPkgDescs <- mapM (readGenericPackageDescription verbosity) depsCabalFiles let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) isInstalled pkgid = not . null . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid @@ -775,17 +776,17 @@ -- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the -- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags - -> Compiler -> Platform -> ProgramConfiguration + -> Compiler -> Platform -> ProgramDb -> UseSandbox -> (Maybe SandboxPackageInfo -> IO ()) -> IO () maybeWithSandboxPackageInfo verbosity configFlags globalFlags - comp platform conf useSandbox cont = + comp platform progdb useSandbox cont = case useSandbox of NoSandbox -> cont Nothing UseSandbox sandboxDir -> withSandboxPackageInfo verbosity configFlags globalFlags - comp platform conf sandboxDir + comp platform progdb sandboxDir (\spi -> cont (Just spi)) -- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that @@ -853,28 +854,12 @@ -- -- Utils (transitionary) -- --- FIXME: configPackageDB' and configCompilerAux' don't really belong in this --- module --- -configPackageDB' :: ConfigFlags -> PackageDBStack -configPackageDB' cfg = - interpretPackageDbFlags userInstall (configPackageDBs cfg) - where - userInstall = fromFlagOrDefault True (configUserInstall cfg) - -configCompilerAux' :: ConfigFlags - -> IO (Compiler, Platform, ProgramConfiguration) -configCompilerAux' configFlags = - configCompilerAuxEx configFlags - --FIXME: make configCompilerAux use a sensible verbosity - { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } - -- | Try to read the most recently configured compiler from the -- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it -- cannot be read. getPersistOrConfigCompiler :: ConfigFlags - -> IO (Compiler, Platform, ProgramConfiguration) + -> IO (Compiler, Platform, ProgramDb) getPersistOrConfigCompiler configFlags = do distPref <- findDistPrefOrDefault (configDistPref configFlags) mlbi <- maybeGetPersistBuildConfig distPref 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 @@ -34,7 +34,7 @@ , makeAbsoluteToCwd, tryCanonicalizePath , tryFindAddSourcePackageDesc ) -import Distribution.Simple.Utils ( die, debug ) +import Distribution.Simple.Utils ( die', debug ) import Distribution.Compat.Exception ( tryIO ) import Distribution.Verbosity ( Verbosity ) @@ -61,12 +61,12 @@ defaultIndexFileName = "00-index.tar" -- | Given a path, ensure that it refers to a local build tree. -buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) -buildTreeRefFromPath refType dir = do +buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) +buildTreeRefFromPath verbosity refType dir = do dirExists <- doesDirectoryExist dir unless dirExists $ - die $ "directory '" ++ dir ++ "' does not exist" - _ <- tryFindAddSourcePackageDesc dir "Error adding source reference." + die' verbosity $ "directory '" ++ dir ++ "' does not exist" + _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference." return . Just $ BuildTreeRef refType dir -- | Given a tar archive entry, try to parse it as a local build tree reference. @@ -120,14 +120,14 @@ -- | Check that the provided path is either an existing directory, or a tar -- archive in an existing directory. -validateIndexPath :: FilePath -> IO FilePath -validateIndexPath path' = do +validateIndexPath :: Verbosity -> FilePath -> IO FilePath +validateIndexPath verbosity path' = do path <- makeAbsoluteToCwd path' if (== ".tar") . takeExtension $ path then return path else do dirExists <- doesDirectoryExist path unless dirExists $ - die $ "directory does not exist: '" ++ path ++ "'" + die' verbosity $ "directory does not exist: '" ++ path ++ "'" return $ path defaultIndexFileName -- | Create an empty index file. @@ -149,11 +149,11 @@ addBuildTreeRefs _ _ [] _ = error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" addBuildTreeRefs verbosity path l' refType = do - checkIndexExists path + checkIndexExists verbosity path l <- liftM nub . mapM tryCanonicalizePath $ l' treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) -- Add only those paths that aren't already in the index. - treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex) + treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex) let entries = map writeBuildTreeRef (catMaybes treesToAdd) unless (null entries) $ do withBinaryFile path ReadWriteMode $ \h -> do @@ -176,7 +176,7 @@ removeBuildTreeRefs _ _ [] = error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" removeBuildTreeRefs verbosity indexPath l = do - checkIndexExists indexPath + checkIndexExists verbosity indexPath let tmpFile = indexPath <.> "tmp" canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr @@ -240,7 +240,7 @@ -> FilePath -> IO [FilePath] listBuildTreeRefs verbosity listIgnored refTypesToList path = do - checkIndexExists path + checkIndexExists verbosity path buildTreeRefs <- case listIgnored of DontListIgnored -> do @@ -274,8 +274,8 @@ -- | Check that the package index file exists and exit with error if it does not. -checkIndexExists :: FilePath -> IO () -checkIndexExists path = do +checkIndexExists :: Verbosity -> FilePath -> IO () +checkIndexExists verbosity path = do indexExists <- doesFileExist path unless indexExists $ - die $ "index does not exist: '" ++ path ++ "'" + die' verbosity $ "index does not exist: '" ++ path ++ "'" 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 @@ -36,12 +36,12 @@ , installDirsFields, withProgramsFields , withProgramOptionsFields , defaultCompiler ) -import Distribution.Client.Dependency.Types ( ConstraintSource (..) ) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..) , InstallFlags(..) , defaultSandboxLocation ) -import Distribution.Utils.NubList ( toNubList ) +import Distribution.Client.Targets ( userConstraintPackageName ) +import Distribution.Utils.NubList ( toNubList ) import Distribution.Simple.Compiler ( Compiler, PackageDB(..) , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate @@ -50,7 +50,8 @@ import Distribution.Simple.Setup ( Flag(..) , ConfigFlags(..), HaddockFlags(..) , fromFlagOrDefault, toFlag, flagToMaybe ) -import Distribution.Simple.Utils ( die, info, notice, warn ) +import Distribution.Simple.Utils ( die', info, notice, warn, debug ) +import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField , liftField, lineNo, locatedErrorMsg @@ -60,8 +61,9 @@ import Distribution.System ( Platform ) import Distribution.Verbosity ( Verbosity, normal ) import Control.Monad ( foldM, liftM2, when, unless ) -import Data.List ( partition ) +import Data.List ( partition, sortBy ) import Data.Maybe ( isJust ) +import Data.Ord ( comparing ) import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Semigroup import System.Directory ( doesDirectoryExist, doesFileExist @@ -275,14 +277,24 @@ -- | Load the user package environment if it exists (the optional "cabal.config" -- file). If it does not exist locally, attempt to load an optional global one. -userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment +userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath + -> IO PackageEnvironment userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do let path = pkgEnvDir userPackageEnvironmentFile - minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) mempty path + minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) + mempty path case (minp, globalConfigLocation) of (Just parseRes, _) -> processConfigParse path parseRes - (_, Just globalLoc) -> maybe (warn verbosity ("no constraints file found at " ++ globalLoc) >> return mempty) (processConfigParse globalLoc) =<< readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) mempty globalLoc - _ -> return mempty + (_, Just globalLoc) -> do + minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) + mempty globalLoc + maybe (warn verbosity ("no constraints file found at " ++ globalLoc) + >> return mempty) + (processConfigParse globalLoc) + minp' + _ -> do + debug verbosity ("no user package environment file found at " ++ pkgEnvDir) + return mempty where processConfigParse path (ParseOk warns parseResult) = do when (not $ null warns) $ warn verbosity $ @@ -297,7 +309,8 @@ -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig loadUserConfig verbosity pkgEnvDir globalConfigLocation = - fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation + fmap pkgEnvSavedConfig $ + userPackageEnvironment verbosity pkgEnvDir globalConfigLocation -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'. @@ -306,7 +319,7 @@ -> IO PackageEnvironment handleParseResult verbosity path minp = case minp of - Nothing -> die $ + Nothing -> die' verbosity $ "The package environment file '" ++ path ++ "' doesn't exist" Just (ParseOk warns parseResult) -> do when (not $ null warns) $ warn verbosity $ @@ -314,7 +327,7 @@ return parseResult Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ "Error parsing package environment file " ++ path + die' verbosity $ "Error parsing package environment file " ++ path ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg -- | Try to load the given package environment file, exiting with error if it @@ -339,7 +352,7 @@ dirExists <- doesDirectoryExist sandboxDir -- TODO: Also check for an initialised package DB? unless dirExists $ - die ("No sandbox exists at " ++ sandboxDir) + die' verbosity ("No sandbox exists at " ++ sandboxDir) info verbosity $ "Using a sandbox located at " ++ sandboxDir let base = basePackageEnvironment @@ -399,7 +412,8 @@ , commaNewLineListField "constraints" (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse) - (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig) + (sortConstraints . configExConstraints + . savedConfigureExFlags . pkgEnvSavedConfig) (\v pkgEnv -> updateConfigureExFlags pkgEnv (\flags -> flags { configExConstraints = v })) @@ -433,6 +447,8 @@ $ pkgEnv } } + + sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) -- | Read the package environment file. readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath 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 @@ -29,7 +29,7 @@ import qualified Data.Map as M import Distribution.Compiler (CompilerId) -import Distribution.Simple.Utils (debug, die, warn) +import Distribution.Simple.Utils (debug, die', warn) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) @@ -38,9 +38,10 @@ import Distribution.Client.Sandbox.Index (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks) ,listBuildTreeRefs) +import Distribution.Client.SetupWrapper import Distribution.Compat.Exception (catchIO) -import Distribution.Client.Compat.Time (ModTime, getCurTime, +import Distribution.Compat.Time (ModTime, getCurTime, getModTime, posixSecondsToModTime) @@ -66,8 +67,8 @@ -- | Read the timestamp file. Exits with error if the timestamp file is -- corrupted. Returns an empty list if the file doesn't exist. -readTimestampFile :: FilePath -> IO [TimestampFileRecord] -readTimestampFile timestampFile = do +readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord] +readTimestampFile verbosity timestampFile = do timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" case reads timestampString of [(version, s)] @@ -90,8 +91,8 @@ _ -> dieCorrupted _ -> dieCorrupted where - dieWrongFormat = die $ wrongFormat ++ deleteAndRecreate - dieCorrupted = die $ corrupted ++ deleteAndRecreate + dieWrongFormat = die' verbosity $ wrongFormat ++ deleteAndRecreate + dieCorrupted = die' verbosity $ corrupted ++ deleteAndRecreate wrongFormat = "The timestamps file is in the wrong format." corrupted = "The timestamps file is corrupted." deleteAndRecreate = " Please delete and recreate the sandbox." @@ -106,12 +107,12 @@ timestampTmpFile = timestampFile <.> "tmp" -- | Read, process and write the timestamp file in one go. -withTimestampFile :: FilePath +withTimestampFile :: Verbosity -> FilePath -> ([TimestampFileRecord] -> IO [TimestampFileRecord]) -> IO () -withTimestampFile sandboxDir process = do +withTimestampFile verbosity sandboxDir process = do let timestampFile = sandboxDir timestampFileName - timestampRecords <- readTimestampFile timestampFile >>= process + timestampRecords <- readTimestampFile verbosity timestampFile >>= process writeTimestampFile timestampFile timestampRecords -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps @@ -155,7 +156,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile compId platform = do let key = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do case lookup key timestampRecords of Just _ -> return timestampRecords Nothing -> do @@ -167,21 +168,21 @@ -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers). -withAddTimestamps :: FilePath -> IO [FilePath] -> IO () -withAddTimestamps sandboxDir act = do +withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO () +withAddTimestamps verbosity sandboxDir act = do let initialTimestamp = minBound - withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act + withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act -- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers). -removeTimestamps :: FilePath -> [FilePath] -> IO () -removeTimestamps idxFile = - withActionOnAllTimestamps removeTimestamps' idxFile . return +removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO () +removeTimestamps verbosity idxFile = + withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the -- given compiler & platform). -withUpdateTimestamps :: FilePath -> CompilerId -> Platform +withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform ->([AddSourceTimestamp] -> IO [FilePath]) -> IO () withUpdateTimestamps = @@ -193,11 +194,12 @@ -- updates the timestamp file. The IO action is run only once. withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> IO [FilePath] -> IO () -withActionOnAllTimestamps f sandboxDir act = - withTimestampFile sandboxDir $ \timestampRecords -> do +withActionOnAllTimestamps f verbosity sandboxDir act = + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do paths <- act return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] @@ -207,14 +209,15 @@ withActionOnCompilerTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> ModTime -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> CompilerId -> Platform -> ([AddSourceTimestamp] -> IO [FilePath]) -> IO () -withActionOnCompilerTimestamps f sandboxDir compId platform act = do +withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do let needle = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) -> if key == needle then do paths <- act timestamps @@ -227,7 +230,9 @@ isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool isDepModified verbosity now (packageDir, timestamp) = do debug verbosity ("Checking whether the dependency is modified: " ++ packageDir) - depSources <- allPackageSourceFiles verbosity packageDir + -- TODO: we should properly plumb the correct options through + -- instead of using defaultSetupScriptOptions + depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir go depSources where @@ -252,7 +257,7 @@ -- ^ The set of all installed add-source deps. -> IO [FilePath] listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do - timestampRecords <- readTimestampFile (sandboxDir timestampFileName) + timestampRecords <- readTimestampFile verbosity (sandboxDir timestampFileName) let needle = timestampRecordKey compId platform timestamps <- maybe noTimestampRecord return (lookup needle timestampRecords) @@ -262,7 +267,7 @@ $ timestamps where - noTimestampRecord = die $ "Сouldn't find a timestamp record for the given " + noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given " ++ "compiler/platform pair. " ++ "Please report this on the Cabal bug tracker: " ++ "https://github.com/haskell/cabal/issues/new ." 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Sandbox.Types @@ -13,13 +12,12 @@ SandboxPackageInfo(..) ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import Distribution.Client.Types (SourcePackage) -import Distribution.Compat.Semigroup (Semigroup((<>))) +import Distribution.Client.Types (UnresolvedSourcePackage) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) -#endif import qualified Data.Set as S -- | Are we using a sandbox? @@ -49,11 +47,11 @@ -- | Data about the packages installed in the sandbox that is passed from -- 'reinstallAddSourceDeps' to the solver. data SandboxPackageInfo = SandboxPackageInfo { - modifiedAddSourceDependencies :: ![SourcePackage], + modifiedAddSourceDependencies :: ![UnresolvedSourcePackage], -- ^ Modified add-source deps that we want to reinstall. These are guaranteed -- to be already installed in the sandbox. - otherAddSourceDependencies :: ![SourcePackage], + otherAddSourceDependencies :: ![UnresolvedSourcePackage], -- ^ Remaining add-source deps. Some of these may be not installed in the -- sandbox. diff --git a/Distribution/Client/SavedFlags.hs b/Distribution/Client/SavedFlags.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SavedFlags.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Distribution.Client.SavedFlags + ( readCommandFlags, writeCommandFlags + , readSavedArgs, writeSavedArgs + ) where + +import Distribution.Simple.Command +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, unintersperse ) +import Distribution.Verbosity + +import Control.Exception ( Exception, throwIO ) +import Control.Monad ( liftM ) +import Data.List ( intercalate ) +import Data.Maybe ( fromMaybe ) +import Data.Typeable +import System.Directory ( doesFileExist ) +import System.FilePath ( takeDirectory ) + + +writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () +writeSavedArgs verbosity path args = do + createDirectoryIfMissingVerbose + (lessVerbose verbosity) True (takeDirectory path) + writeFile path (intercalate "\0" args) + + +-- | Write command-line flags to a file, separated by null characters. This +-- format is also suitable for the @xargs -0@ command. Using the null +-- character also avoids the problem of escaping newlines or spaces, +-- because unlike other whitespace characters, the null character is +-- not valid in command-line arguments. +writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO () +writeCommandFlags verbosity path command flags = + writeSavedArgs verbosity path (commandShowOptions command flags) + + +readSavedArgs :: FilePath -> IO (Maybe [String]) +readSavedArgs path = do + exists <- doesFileExist path + if exists + then liftM (Just . unintersperse '\0') (readFile path) + else return Nothing + + +-- | Read command-line arguments, separated by null characters, from a file. +-- Returns the default flags if the file does not exist. +readCommandFlags :: FilePath -> CommandUI flags -> IO flags +readCommandFlags path command = do + savedArgs <- liftM (fromMaybe []) (readSavedArgs path) + case (commandParseArgs command True savedArgs) of + CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs) + CommandList _ -> throwIO (SavedArgsErrorList savedArgs) + CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs) + CommandReadyToGo (mkFlags, _) -> + return (mkFlags (commandDefaultFlags command)) + +-- ----------------------------------------------------------------------------- +-- * Exceptions +-- ----------------------------------------------------------------------------- + +data SavedArgsError + = SavedArgsErrorHelp Args + | SavedArgsErrorList Args + | SavedArgsErrorOther Args [String] + deriving (Typeable) + +instance Show SavedArgsError where + show (SavedArgsErrorHelp args) = + "unexpected flag '--help', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorList args) = + "unexpected flag '--list-options', saved command line was:\n" + ++ intercalate " " args + show (SavedArgsErrorOther args errs) = + "saved command line was:\n" + ++ intercalate " " args ++ "\n" + ++ "encountered errors:\n" + ++ intercalate "\n" errs + +instance Exception SavedArgsError diff --git a/Distribution/Client/Security/DNS.hs b/Distribution/Client/Security/DNS.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Security/DNS.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Security.DNS + ( queryBootstrapMirrors + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Control.Monad +import Control.DeepSeq (force) +import Control.Exception (SomeException, evaluate, try) +import Network.URI (URI(..), URIAuth(..), parseURI) + +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Simple.Program.Db + ( emptyProgramDb, addKnownProgram + , configureAllKnownPrograms, lookupProgram ) +import Distribution.Simple.Program + ( simpleProgram + , programInvocation + , getProgramInvocationOutput ) +import Distribution.Compat.Exception (displayException) + +-- | Try to lookup RFC1464-encoded mirror urls for a Hackage +-- repository url by performing a DNS TXT lookup on the +-- @_mirrors.@-prefixed URL hostname. +-- +-- Example: for @http://hackage.haskell.org/@ +-- perform a DNS TXT query for the hostname +-- @_mirrors.hackage.haskell.org@ which may look like e.g. +-- +-- > _mirrors.hackage.haskell.org. 300 IN TXT +-- > "0.urlbase=http://hackage.fpcomplete.com/" +-- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/" +-- +-- NB: hackage-security doesn't require DNS lookups being trustworthy, +-- as the trust is established via the cryptographically signed TUF +-- meta-data that is retrieved from the resolved Hackage repository. +-- Moreover, we already have to protect against a compromised +-- @hackage.haskell.org@ DNS entry, so an the additional +-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't +-- constitute a significant new attack vector anyway. +-- +queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do + progdb <- configureAllKnownPrograms verbosity $ + addKnownProgram nslookupProg emptyProgramDb + + case lookupProgram nslookupProg progdb of + Nothing -> do + warn verbosity "'nslookup' tool missing - can't locate mirrors" + return [] + + Just nslookup -> do + let mirrorsDnsName = "_mirrors." ++ uriRegName auth + + mirrors' <- try $ do + out <- getProgramInvocationOutput verbosity $ + programInvocation nslookup ["-query=TXT", mirrorsDnsName] + evaluate (force $ extractMirrors mirrorsDnsName out) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + forM_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + where + nslookupProg = simpleProgram "nslookup" + +-- | Extract list of mirrors from @nslookup -query=TXT@ output. +extractMirrors :: String -> String -> [URI] +extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0 + , h == hostname + , e <- ents + , Just (k,v) <- [splitRfc1464 e] + , Just kn <- [isUrlBase k] + ] + + isUrlBase :: String -> Maybe Int + isUrlBase s + | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns + | otherwise = Nothing + where + ns = take (length s - 8) s + +-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly +parseNsLookupTxt :: String -> Maybe [(String,[String])] +parseNsLookupTxt = go0 [] [] + where + -- approximate grammar: + -- := { } + -- ( starts at begin of line, but may span multiple lines) + -- := ^ TAB "text =" { } + -- := string enclosed by '"'s ('\' and '"' are \-escaped) + + -- scan for ^ "text =" + go0 [] _ [] = Nothing + go0 res _ [] = Just (reverse res) + go0 res _ ('\n':xs) = go0 res [] xs + go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs) + go0 res lw (x:xs) = go0 res (x:lw) xs + + -- collect at least one + go1 res lw qs ('"':xs) = case qstr "" xs of + Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs') + Nothing -> Nothing -- bad quoting + go1 _ _ [] _ = Nothing -- missing qstring + go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs + + qstr _ ('\n':_) = Nothing -- We don't support unquoted LFs + qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs + qstr acc ('\\':'"':cs) = qstr ('"':acc) cs + qstr acc ('"':cs) = Just (reverse acc, cs) + qstr acc (c:cs) = qstr (c:acc) cs + qstr _ [] = Nothing + +-- | Split a TXT string into key and value according to RFC1464. +-- Returns 'Nothing' if parsing fails. +splitRfc1464 :: String -> Maybe (String,String) +splitRfc1464 = go "" + where + go _ [] = Nothing + go acc ('`':c:cs) = go (c:acc) cs + go acc ('=':cs) = go2 (reverse acc) "" cs + go acc (c:cs) + | isSpace c = go acc cs + | otherwise = go (c:acc) cs + + go2 k acc [] = Just (k,reverse acc) + go2 _ _ ['`'] = Nothing + go2 k acc ('`':c:cs) = go2 k (c:acc) cs + go2 k acc (c:cs) = go2 k (c:acc) cs diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -18,10 +18,11 @@ ( globalCommand, GlobalFlags(..), defaultGlobalFlags , RepoContext(..), withRepoContext , configureCommand, ConfigFlags(..), filterConfigureFlags + , configPackageDB', configCompilerAux' , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , configureExOptions , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , replCommand, testCommand, benchmarkCommand + , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) @@ -32,10 +33,11 @@ , fetchCommand, FetchFlags(..) , freezeCommand, FreezeFlags(..) , genBoundsCommand + , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) , getCommand, unpackCommand, GetFlags(..) , checkCommand , formatCommand - , uploadCommand, UploadFlags(..) + , uploadCommand, UploadFlags(..), IsCandidate(..) , reportCommand, ReportFlags(..) , runCommand , initCommand, IT.InitFlags(..) @@ -47,6 +49,7 @@ , userConfigCommand, UserConfigFlags(..) , manpageCommand + , applyFlagDefaults , parsePackageArgs --TODO: stop exporting these: , showRepo @@ -54,12 +57,17 @@ , readRepo ) where +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Dependency.Types - ( PreSolver(..), ConstraintSource(..) ) + ( PreSolver(..) ) +import Distribution.Client.IndexUtils.Timestamp + ( IndexState ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets @@ -67,40 +75,46 @@ import Distribution.Utils.NubList ( NubList, toNubList, fromNubList) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Settings -import Distribution.Simple.Compiler (PackageDB) -import Distribution.Simple.Program - ( defaultProgramConfiguration ) +import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack ) +import Distribution.Simple.Program (ProgramDb, defaultProgramDb) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Configure ( computeEffectiveProfiling ) +import Distribution.Simple.Configure + ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling ) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags , TestFlags(..), BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) , readPackageDbList, showPackageDbList - , Flag(..), toFlag, flagToMaybe, flagToList - , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg - , readPToMaybe, optionNumJobs ) + , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag + , BooleanFlag(..), optionVerbosity + , boolOpt, boolOpt', trueArg, falseArg + , optionNumJobs ) import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs(dynlibdir, sysconfdir) - , toPathTemplate, fromPathTemplate ) + ( PathTemplate, InstallDirs(..) + , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version - ( Version(Version), anyVersion, thisVersion ) + ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package - ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) + ( PackageIdentifier, PackageName, packageName, packageVersion ) +import Distribution.Types.Dependency import Distribution.PackageDescription ( BuildType(..), RepoKind(..) ) +import Distribution.System ( Platform ) import Distribution.Text ( Text(..), display ) import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse - ( ReadP, char, munch1, pfail, (+++) ) -import Distribution.Compat.Semigroup + ( ReadP, char, munch1, pfail, sepBy1, (+++) ) +import Distribution.ParseUtils + ( readPToMaybe ) import Distribution.Verbosity - ( Verbosity, normal ) + ( Verbosity, lessVerbose, normal, verboseNoFlags ) import Distribution.Simple.Utils ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags @@ -108,21 +122,22 @@ , RepoContext(..), withRepoContext ) -import Data.Char - ( isAlphaNum ) import Data.List - ( intercalate, deleteFirstsBy ) -import Data.Maybe - ( maybeToList, fromMaybe ) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary) -import Control.Monad - ( liftM ) + ( deleteFirstsBy ) import System.FilePath ( () ) import Network.URI ( parseAbsoluteURI, uriToString ) +applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) = + ( commandDefaultFlags configureCommand <> configFlags + , defaultConfigExFlags <> configExFlags + , defaultInstallFlags <> installFlags + , Cabal.defaultHaddockFlags <> haddockFlags + ) + globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { commandName = "", @@ -153,6 +168,7 @@ , "get" , "init" , "configure" + , "reconfigure" , "build" , "clean" , "run" @@ -165,12 +181,22 @@ , "report" , "freeze" , "gen-bounds" + , "outdated" + , "doctest" , "haddock" , "hscolour" , "copy" , "register" , "sandbox" , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" ] maxlen = maximum $ [length name | (name, _) <- cmdDescs] align str = str ++ replicate (maxlen - length str) ' ' @@ -216,15 +242,28 @@ , par , addCmd "freeze" , addCmd "gen-bounds" + , addCmd "outdated" + , addCmd "doctest" , addCmd "haddock" , addCmd "hscolour" , addCmd "copy" , addCmd "register" + , addCmd "reconfigure" , par , startGroup "sandbox" , addCmd "sandbox" , addCmd "exec" , addCmdCustom "repl" "Open interpreter with access to sandbox packages." + , par + , startGroup "new-style projects (beta)" + , addCmd "new-build" + , addCmd "new-configure" + , addCmd "new-repl" + , addCmd "new-run" + , addCmd "new-test" + , addCmd "new-bench" + , addCmd "new-freeze" + , addCmd "new-haddock" ] ++ if null otherCmds then [] else par :startGroup "other" :[addCmd n | n <- otherCmds]) @@ -294,6 +333,10 @@ "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") + ,option [] ["nix"] + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" + globalNix (\v flags -> flags { globalNix = v }) + (boolOpt [] []) ] -- arguments we don't want shown in the help @@ -343,74 +386,100 @@ ++ " with some package-specific flag.\n" } where - c = Cabal.configureCommand defaultProgramConfiguration + c = Cabal.configureCommand defaultProgramDb configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand +-- | Given some 'ConfigFlags' for the version of Cabal that +-- cabal-install was built with, and a target older 'Version' of +-- Cabal that we want to pass these flags to, convert the +-- flags into a form that will be accepted by the older +-- Setup script. Generally speaking, this just means filtering +-- out flags that the old Cabal library doesn't understand, but +-- in some cases it may also mean "emulating" a feature using +-- some more legacy flags. filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion - | cabalLibVersion >= Version [1,24,1] [] = flags_latest - -- ^ NB: we expect the latest version to be the most common case. - | cabalLibVersion < Version [1,3,10] [] = flags_1_3_10 - | cabalLibVersion < Version [1,10,0] [] = flags_1_10_0 - | cabalLibVersion < Version [1,12,0] [] = flags_1_12_0 - | cabalLibVersion < Version [1,14,0] [] = flags_1_14_0 - | cabalLibVersion < Version [1,18,0] [] = flags_1_18_0 - | cabalLibVersion < Version [1,19,1] [] = flags_1_19_0 - | cabalLibVersion < Version [1,19,2] [] = flags_1_19_1 - | cabalLibVersion < Version [1,21,1] [] = flags_1_20_0 - | cabalLibVersion < Version [1,22,0] [] = flags_1_21_0 - | cabalLibVersion < Version [1,23,0] [] = flags_1_22_0 - | cabalLibVersion < Version [1,24,1] [] = flags_1_24_0 + -- NB: we expect the latest version to be the most common case, + -- so test it first. + | cabalLibVersion >= mkVersion [1,25,0] = flags_latest + -- The naming convention is that flags_version gives flags with + -- all flags *introduced* in version eliminated. + -- It is NOT the latest version of Cabal library that + -- these flags work for; version of introduction is a more + -- natural metric. + | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10 + | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0 + | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0 + | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0 + | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0 + | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1 + | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2 + | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1 + | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 + | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 + | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 | otherwise = flags_latest where - (profEnabledLib, profEnabledExe) = computeEffectiveProfiling flags flags_latest = flags { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. configConstraints = [], - -- Passing '--allow-newer' to Setup.hs is unnecessary, we use + -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use -- '--exact-configuration' instead. - configAllowNewer = Just Cabal.AllowNewerNone + configAllowOlder = Just (Cabal.AllowOlder Cabal.RelaxDepsNone), + configAllowNewer = Just (Cabal.AllowNewer Cabal.RelaxDepsNone) } - -- Cabal < 1.24.1 doesn't know about --dynlibdir. - flags_1_24_0 = flags_latest { configInstallDirs = configInstallDirs_1_24_0} - configInstallDirs_1_24_0 = (configInstallDirs flags) { dynlibdir = NoFlag } - + flags_1_25_0 = flags_latest { + -- Cabal < 1.25.0 doesn't know about --dynlibdir. + configInstallDirs = configInstallDirs_1_25_0, + -- Cabal < 1.25 doesn't have extended verbosity syntax + configVerbosity = fmap verboseNoFlags (configVerbosity flags_latest), + -- Cabal < 1.25 doesn't support --deterministic + configDeterministic = mempty + } + configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in + dirs { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = maybeToFlag $ + combinePathTemplate <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } -- Cabal < 1.23 doesn't know about '--profiling-detail'. -- Cabal < 1.23 has a hacked up version of 'enable-profiling' -- which we shouldn't use. - flags_1_22_0 = flags_1_24_0 { configProfDetail = NoFlag + (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags + flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag , configProfLibDetail = NoFlag , configIPID = NoFlag , configProf = NoFlag - , configProfExe = Flag profEnabledExe - , configProfLib = Flag profEnabledLib + , configProfExe = Flag tryExeProfiling + , configProfLib = Flag tryLibProfiling } -- Cabal < 1.22 doesn't know about '--disable-debug-info'. - flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag } + flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag } -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' -- Cabal < 1.21.1 doesn't know about 'enable-profiling' - -- (but we already dealt with it in flags_1_22_0) - flags_1_20_0 = - flags_1_21_0 { configRelocatable = NoFlag + -- (but we already dealt with it in flags_1_23_0) + flags_1_21_1 = + flags_1_22_0 { configRelocatable = NoFlag , configCoverage = NoFlag , configLibCoverage = configCoverage flags } -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and -- '--enable-library-stripping'. - flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag + flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag , configStripLibs = NoFlag } -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. - flags_1_19_0 = flags_1_19_1 { configDependencies = [] + flags_1_19_1 = flags_1_19_2 { configDependencies = [] , configConstraints = configConstraints flags } -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. - flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList [] + flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList [] , configInstallDirs = configInstallDirs_1_18_0} - configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_0) { sysconfdir = NoFlag } + configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag } -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic' @@ -422,6 +491,21 @@ -- Cabal < 1.3.10 does not grok the '--constraints' flag. flags_1_3_10 = flags_1_10_0 { configConstraints = [] } +-- | Get the package database settings from 'ConfigFlags', accounting for +-- @--package-db@ and @--user@ flags. +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) + where + userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg) + +-- | Configure the compiler, but reduce verbosity during this step. +configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) +configCompilerAux' configFlags = + configCompilerAuxEx configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } + -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------ @@ -490,6 +574,28 @@ instance Semigroup ConfigExFlags where (<>) = gmappend +reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags) +reconfigureCommand + = configureExCommand + { commandName = "reconfigure" + , commandSynopsis = "Reconfigure the package if necessary." + , commandDescription = Just $ \pname -> wrapText $ + "Run `configure` with the most recently used flags, or append FLAGS " + ++ "to the most recently used configuration. " + ++ "Accepts the same flags as `" ++ pname ++ " configure'. " + ++ "If the package has never been configured, the default flags are " + ++ "used." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " reconfigure\n" + ++ " Configure with the most recently used flags.\n" + ++ " " ++ pname ++ " reconfigure -w PATH\n" + ++ " Reconfigure with the most recently used flags,\n" + ++ " but use the compiler at PATH.\n\n" + , commandUsage = usageAlternatives "reconfigure" [ "[FLAGS]" ] + , commandDefaultFlags = mempty + } + -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------ @@ -524,7 +630,7 @@ setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) - parent = Cabal.buildCommand defaultProgramConfiguration + parent = Cabal.buildCommand defaultProgramDb instance Monoid BuildExFlags where mempty = gmempty @@ -550,7 +656,7 @@ setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) - parent = Cabal.replCommand defaultProgramConfiguration + parent = Cabal.replCommand defaultProgramDb -- ------------------------------------------------------------ -- * Test command @@ -565,7 +671,7 @@ (commandOptions parent showOrParseArgs) ++ liftOptions get2 set2 - (Cabal.buildOptions progConf showOrParseArgs) + (Cabal.buildOptions progDb showOrParseArgs) ++ liftOptions get3 set3 (buildExOptions showOrParseArgs) } @@ -574,8 +680,8 @@ get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) - parent = Cabal.testCommand - progConf = defaultProgramConfiguration + parent = Cabal.testCommand + progDb = defaultProgramDb -- ------------------------------------------------------------ -- * Bench command @@ -590,7 +696,7 @@ (commandOptions parent showOrParseArgs) ++ liftOptions get2 set2 - (Cabal.buildOptions progConf showOrParseArgs) + (Cabal.buildOptions progDb showOrParseArgs) ++ liftOptions get3 set3 (buildExOptions showOrParseArgs) } @@ -599,8 +705,8 @@ get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) - parent = Cabal.benchmarkCommand - progConf = defaultProgramConfiguration + parent = Cabal.benchmarkCommand + progDb = defaultProgramDb -- ------------------------------------------------------------ -- * Fetch command @@ -612,10 +718,12 @@ fetchDryRun :: Flag Bool, fetchSolver :: Flag PreSolver, fetchMaxBackjumps :: Flag Int, - fetchReorderGoals :: Flag Bool, - fetchIndependentGoals :: Flag Bool, - fetchShadowPkgs :: Flag Bool, - fetchStrongFlags :: Flag Bool, + fetchReorderGoals :: Flag ReorderGoals, + fetchCountConflicts :: Flag CountConflicts, + fetchIndependentGoals :: Flag IndependentGoals, + fetchShadowPkgs :: Flag ShadowPkgs, + fetchStrongFlags :: Flag StrongFlags, + fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, fetchVerbosity :: Flag Verbosity } @@ -626,10 +734,12 @@ fetchDryRun = toFlag False, fetchSolver = Flag defaultSolver, fetchMaxBackjumps = Flag defaultMaxBackjumps, - fetchReorderGoals = Flag False, - fetchIndependentGoals = Flag False, - fetchShadowPkgs = Flag False, - fetchStrongFlags = Flag False, + fetchReorderGoals = Flag (ReorderGoals False), + fetchCountConflicts = Flag (CountConflicts True), + fetchIndependentGoals = Flag (IndependentGoals False), + fetchShadowPkgs = Flag (ShadowPkgs False), + fetchStrongFlags = Flag (StrongFlags False), + fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), fetchVerbosity = toFlag normal } @@ -673,9 +783,11 @@ optionSolverFlags showOrParseArgs fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) + fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) + fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) } @@ -689,10 +801,12 @@ freezeBenchmarks :: Flag Bool, freezeSolver :: Flag PreSolver, freezeMaxBackjumps :: Flag Int, - freezeReorderGoals :: Flag Bool, - freezeIndependentGoals :: Flag Bool, - freezeShadowPkgs :: Flag Bool, - freezeStrongFlags :: Flag Bool, + freezeReorderGoals :: Flag ReorderGoals, + freezeCountConflicts :: Flag CountConflicts, + freezeIndependentGoals :: Flag IndependentGoals, + freezeShadowPkgs :: Flag ShadowPkgs, + freezeStrongFlags :: Flag StrongFlags, + freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, freezeVerbosity :: Flag Verbosity } @@ -703,10 +817,12 @@ freezeBenchmarks = toFlag False, freezeSolver = Flag defaultSolver, freezeMaxBackjumps = Flag defaultMaxBackjumps, - freezeReorderGoals = Flag False, - freezeIndependentGoals = Flag False, - freezeShadowPkgs = Flag False, - freezeStrongFlags = Flag False, + freezeReorderGoals = Flag (ReorderGoals False), + freezeCountConflicts = Flag (CountConflicts True), + freezeIndependentGoals = Flag (IndependentGoals False), + freezeShadowPkgs = Flag (ShadowPkgs False), + freezeStrongFlags = Flag (StrongFlags False), + freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), freezeVerbosity = toFlag normal } @@ -726,7 +842,8 @@ commandUsage = usageFlags "freeze", commandDefaultFlags = defaultFreezeFlags, commandOptions = \ showOrParseArgs -> [ - optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) + optionVerbosity freezeVerbosity + (\v flags -> flags { freezeVerbosity = v }) , option [] ["dry-run"] "Do not freeze anything, only print what would be frozen" @@ -734,34 +851,44 @@ trueArg , option [] ["tests"] - "freezing of the dependencies of any tests suites in the package description file." + ("freezing of the dependencies of any tests suites " + ++ "in the package description file.") freezeTests (\v flags -> flags { freezeTests = v }) (boolOpt [] []) , option [] ["benchmarks"] - "freezing of the dependencies of any benchmarks suites in the package description file." + ("freezing of the dependencies of any benchmarks suites " + ++ "in the package description file.") freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) (boolOpt [] []) ] ++ - optionSolver freezeSolver (\v flags -> flags { freezeSolver = v }) : + optionSolver + freezeSolver (\v flags -> flags { freezeSolver = v }): optionSolverFlags showOrParseArgs freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) + freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) + freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) } +-- ------------------------------------------------------------ +-- * 'gen-bounds' command +-- ------------------------------------------------------------ + genBoundsCommand :: CommandUI FreezeFlags genBoundsCommand = CommandUI { commandName = "gen-bounds", commandSynopsis = "Generate dependency bounds.", commandDescription = Just $ \_ -> wrapText $ "Generates bounds for all dependencies that do not currently have them. " - ++ "Generated bounds are printed to stdout. You can then paste them into your .cabal file.\n" + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" ++ "\n", commandNotes = Nothing, commandUsage = usageFlags "gen-bounds", @@ -772,6 +899,116 @@ } -- ------------------------------------------------------------ +-- * 'outdated' command +-- ------------------------------------------------------------ + +data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone + | IgnoreMajorVersionBumpsAll + | IgnoreMajorVersionBumpsSome [PackageName] + +instance Monoid IgnoreMajorVersionBumps where + mempty = IgnoreMajorVersionBumpsNone + mappend = (<>) + +instance Semigroup IgnoreMajorVersionBumps where + IgnoreMajorVersionBumpsNone <> r = r + l@IgnoreMajorVersionBumpsAll <> _ = l + l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l + (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r + (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = + IgnoreMajorVersionBumpsSome (a ++ b) + +data OutdatedFlags = OutdatedFlags { + outdatedVerbosity :: Flag Verbosity, + outdatedFreezeFile :: Flag Bool, + outdatedNewFreezeFile :: Flag Bool, + outdatedSimpleOutput :: Flag Bool, + outdatedExitCode :: Flag Bool, + outdatedQuiet :: Flag Bool, + outdatedIgnore :: [PackageName], + outdatedMinor :: Maybe IgnoreMajorVersionBumps + } + +defaultOutdatedFlags :: OutdatedFlags +defaultOutdatedFlags = OutdatedFlags { + outdatedVerbosity = toFlag normal, + outdatedFreezeFile = mempty, + outdatedNewFreezeFile = mempty, + outdatedSimpleOutput = mempty, + outdatedExitCode = mempty, + outdatedQuiet = mempty, + outdatedIgnore = mempty, + outdatedMinor = mempty + } + +outdatedCommand :: CommandUI OutdatedFlags +outdatedCommand = CommandUI { + commandName = "outdated", + commandSynopsis = "Check for outdated dependencies", + commandDescription = Just $ \_ -> wrapText $ + "Checks for outdated dependencies in the package description file " + ++ "or freeze file", + commandNotes = Nothing, + commandUsage = usageFlags "outdated", + commandDefaultFlags = defaultOutdatedFlags, + commandOptions = \ _ -> [ + optionVerbosity outdatedVerbosity + (\v flags -> flags { outdatedVerbosity = v }) + + ,option [] ["freeze-file"] + "Act on the freeze file" + outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) + trueArg + + ,option [] ["new-freeze-file"] + "Act on the new-style freeze file" + outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) + trueArg + + ,option [] ["simple-output"] + "Only print names of outdated dependencies, one per line" + outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) + trueArg + + ,option [] ["exit-code"] + "Exit with non-zero when there are outdated dependencies" + outdatedExitCode (\v flags -> flags { outdatedExitCode = v }) + trueArg + + ,option ['q'] ["quiet"] + "Don't print any output. Implies '--exit-code' and '-v0'" + outdatedQuiet (\v flags -> flags { outdatedQuiet = v }) + trueArg + + ,option [] ["ignore"] + "Packages to ignore" + outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) + (reqArg "PKGS" pkgNameListParser (map display)) + + ,option [] ["minor"] + "Ignore major version bumps for these packages" + outdatedMinor (\v flags -> flags { outdatedMinor = v }) + (optArg "PKGS" ignoreMajorVersionBumpsParser + (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) + ] + } + where + ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) + -> [Maybe String] + ignoreMajorVersionBumpsPrinter Nothing = [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] + ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = + map (Just . display) $ pkgs + + ignoreMajorVersionBumpsParser = + (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser + + pkgNameListParser = readP_to_E + ("Couldn't parse the list of package names: " ++) + (Parse.sepBy1 parse (Parse.char ',')) + +-- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------ @@ -892,7 +1129,7 @@ setFst a (_,b) = (a,b) setSnd b (a,_) = (a,b) - parent = Cabal.buildCommand defaultProgramConfiguration + parent = Cabal.buildCommand defaultProgramDb -- ------------------------------------------------------------ -- * Report flags @@ -951,6 +1188,7 @@ data GetFlags = GetFlags { getDestDir :: Flag FilePath, getPristine :: Flag Bool, + getIndexState :: Flag IndexState, getSourceRepository :: Flag (Maybe RepoKind), getVerbosity :: Flag Verbosity } deriving Generic @@ -959,6 +1197,7 @@ defaultGetFlags = GetFlags { getDestDir = mempty, getPristine = mempty, + getIndexState = mempty, getSourceRepository = mempty, getVerbosity = toFlag normal } @@ -996,6 +1235,20 @@ (Flag Nothing) (map (fmap show) . flagToList)) + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ + "This determines which package versions are available as well as " ++ + ".cabal file revision is selected (unless --pristine is used).") + getIndexState (\v flags -> flags { getIndexState = v }) + (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " ++ ".cabal file with the latest revision from the package archive.") @@ -1150,26 +1403,39 @@ installHaddockIndex :: Flag PathTemplate, installDryRun :: Flag Bool, installMaxBackjumps :: Flag Int, - installReorderGoals :: Flag Bool, - installIndependentGoals :: Flag Bool, - installShadowPkgs :: Flag Bool, - installStrongFlags :: Flag Bool, + installReorderGoals :: Flag ReorderGoals, + installCountConflicts :: Flag CountConflicts, + installIndependentGoals :: Flag IndependentGoals, + installShadowPkgs :: Flag ShadowPkgs, + installStrongFlags :: Flag StrongFlags, + installAllowBootLibInstalls :: Flag AllowBootLibInstalls, installReinstall :: Flag Bool, - installAvoidReinstalls :: Flag Bool, + installAvoidReinstalls :: Flag AvoidReinstalls, installOverrideReinstall :: Flag Bool, installUpgradeDeps :: Flag Bool, installOnly :: Flag Bool, installOnlyDeps :: Flag Bool, + installIndexState :: Flag IndexState, installRootCmd :: Flag String, installSummaryFile :: NubList PathTemplate, installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installReportPlanningFailure :: Flag Bool, installSymlinkBinDir :: Flag FilePath, + installPerComponent :: Flag Bool, installOneShot :: Flag Bool, installNumJobs :: Flag (Maybe Int), + installKeepGoing :: Flag Bool, installRunTests :: Flag Bool, - installOfflineMode :: Flag Bool + installOfflineMode :: Flag Bool, + -- | The cabal project file name; defaults to @cabal.project@. + -- Th name itself denotes the cabal project file name, but it also + -- is the base of auxiliary project files, such as + -- @cabal.project.local@ and @cabal.project.freeze@ which are also + -- read and written out in some cases. If the path is not found + -- in the current working directory, we will successively probe + -- relative to parent directories until this name is found. + installProjectFileName :: Flag FilePath } deriving (Eq, Generic) @@ -1181,26 +1447,32 @@ installHaddockIndex = Flag docIndexFile, installDryRun = Flag False, installMaxBackjumps = Flag defaultMaxBackjumps, - installReorderGoals = Flag False, - installIndependentGoals= Flag False, - installShadowPkgs = Flag False, - installStrongFlags = Flag False, + installReorderGoals = Flag (ReorderGoals False), + installCountConflicts = Flag (CountConflicts True), + installIndependentGoals= Flag (IndependentGoals False), + installShadowPkgs = Flag (ShadowPkgs False), + installStrongFlags = Flag (StrongFlags False), + installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), installReinstall = Flag False, - installAvoidReinstalls = Flag False, + installAvoidReinstalls = Flag (AvoidReinstalls False), installOverrideReinstall = Flag False, installUpgradeDeps = Flag False, installOnly = Flag False, installOnlyDeps = Flag False, + installIndexState = mempty, installRootCmd = mempty, installSummaryFile = mempty, installLogFile = mempty, installBuildReports = Flag NoReports, installReportPlanningFailure = Flag False, installSymlinkBinDir = mempty, + installPerComponent = Flag True, installOneShot = Flag False, installNumJobs = mempty, + installKeepGoing = Flag False, installRunTests = mempty, - installOfflineMode = Flag False + installOfflineMode = Flag False, + installProjectFileName = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" @@ -1210,7 +1482,7 @@ defaultMaxBackjumps = 2000 defaultSolver :: PreSolver -defaultSolver = Choose +defaultSolver = AlwaysModular allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) @@ -1251,7 +1523,7 @@ ++ " continue working as long as bindir and datadir are left untouched.", commandNotes = Just $ \pname -> ( case commandNotes - $ Cabal.configureCommand defaultProgramConfiguration + $ Cabal.configureCommand defaultProgramDb of Just desc -> desc pname ++ "\n" Nothing -> "" ) @@ -1326,9 +1598,11 @@ optionSolverFlags showOrParseArgs installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) + installCountConflicts (\v flags -> flags { installCountConflicts = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) - installStrongFlags (\v flags -> flags { installStrongFlags = v }) ++ + installStrongFlags (\v flags -> flags { installStrongFlags = v }) + installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) ++ [ option [] ["reinstall"] "Install even if it means installing the same version again." @@ -1337,7 +1611,8 @@ , option [] ["avoid-reinstalls"] "Do not select versions that would destructively overwrite installed packages." - installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v }) + (fmap asBool . installAvoidReinstalls) + (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v }) (yesNoOpt showOrParseArgs) , option [] ["force-reinstalls"] @@ -1360,8 +1635,20 @@ installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) (yesNoOpt showOrParseArgs) + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") + installIndexState (\v flags -> flags { installIndexState = v }) + (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + , option [] ["root-cmd"] - "Command used to gain root privileges, when installing with --global." + "(No longer supported, do not use.)" installRootCmd (\v flags -> flags { installRootCmd = v }) (reqArg' "COMMAND" toFlag flagToList) @@ -1394,6 +1681,11 @@ installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) trueArg + , option "" ["per-component"] + "Per-component builds when possible" + installPerComponent (\v flags -> flags { installPerComponent = v }) + (boolOpt [] []) + , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) @@ -1407,10 +1699,20 @@ , optionNumJobs installNumJobs (\v flags -> flags { installNumJobs = v }) + , option [] ["keep-going"] + "After a build failure, continue to build other unaffected packages." + installKeepGoing (\v flags -> flags { installKeepGoing = v }) + trueArg + , option [] ["offline"] "Don't download packages from the Internet." installOfflineMode (\v flags -> flags { installOfflineMode = v }) (yesNoOpt showOrParseArgs) + + , option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + installProjectFileName (\v flags -> flags {installProjectFileName = v}) + (reqArgFlag "FILE") ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" -- avoids ParseArgs -> @@ -1432,8 +1734,12 @@ -- * Upload flags -- ------------------------------------------------------------ +-- | Is this a candidate package or a package to be published? +data IsCandidate = IsCandidate | IsPublished + deriving Eq + data UploadFlags = UploadFlags { - uploadCheck :: Flag Bool, + uploadCandidate :: Flag IsCandidate, uploadDoc :: Flag Bool, uploadUsername :: Flag Username, uploadPassword :: Flag Password, @@ -1443,7 +1749,7 @@ defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags { - uploadCheck = toFlag False, + uploadCandidate = toFlag IsCandidate, uploadDoc = toFlag False, uploadUsername = mempty, uploadPassword = mempty, @@ -1463,15 +1769,19 @@ "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", commandDefaultFlags = defaultUploadFlags, commandOptions = \_ -> - [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) + [optionVerbosity uploadVerbosity + (\v flags -> flags { uploadVerbosity = v }) - ,option ['c'] ["check"] - "Do not upload, just do QA checks." - uploadCheck (\v flags -> flags { uploadCheck = v }) - trueArg + ,option [] ["publish"] + "Publish the package instead of uploading it as a candidate." + uploadCandidate (\v flags -> flags { uploadCandidate = v }) + (noArg (Flag IsPublished)) ,option ['d'] ["documentation"] - "Upload documentation instead of a source package. Cannot be used together with --check." + ("Upload documentation instead of a source package. " + ++ "By default, this uploads documentation for a package candidate. " + ++ "To upload documentation for " + ++ "a published package, combine with --publish.") uploadDoc (\v flags -> flags { uploadDoc = v }) trueArg @@ -1683,9 +1993,6 @@ , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] } - where readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing -- ------------------------------------------------------------ -- * SDist flags @@ -1698,7 +2005,7 @@ } deriving (Show, Generic) -data ArchiveFormat = TargzFormat | ZipFormat -- | ... +data ArchiveFormat = TargzFormat | ZipFormat -- ... deriving (Show, Eq) defaultSDistExFlags :: SDistExFlags @@ -1936,12 +2243,14 @@ -- ------------------------------------------------------------ data ExecFlags = ExecFlags { - execVerbosity :: Flag Verbosity + execVerbosity :: Flag Verbosity, + execDistPref :: Flag FilePath } deriving Generic defaultExecFlags :: ExecFlags defaultExecFlags = ExecFlags { - execVerbosity = toFlag normal + execVerbosity = toFlag normal, + execDistPref = NoFlag } execCommand :: CommandUI ExecFlags @@ -1982,9 +2291,12 @@ "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n", commandDefaultFlags = defaultExecFlags, - commandOptions = \_ -> + commandOptions = \showOrParseArgs -> [ optionVerbosity execVerbosity (\v flags -> flags { execVerbosity = v }) + , Cabal.optionDistPref + execDistPref (\d flags -> flags { execDistPref = d }) + showOrParseArgs ] } @@ -2067,7 +2379,7 @@ -> OptionField flags optionSolver get set = option [] ["solver"] - ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.") + ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") get set (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers) (toFlag `fmap` parse)) @@ -2075,12 +2387,15 @@ optionSolverFlags :: ShowOrParseArgs -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) - -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) - -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) - -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) - -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) + -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) + -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) + -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl = +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig + getsip setsip getstrfl setstrfl getib setib = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -2088,23 +2403,37 @@ (map show . flagToList)) , option [] ["reorder-goals"] "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." - getrg setrg + (fmap asBool . getrg) + (setrg . fmap ReorderGoals) (yesNoOpt showOrParseArgs) - -- TODO: Disabled for now because it does not work as advertised (yet). + , option [] ["count-conflicts"] + "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + (fmap asBool . getcc) + (setcc . fmap CountConflicts) + (yesNoOpt showOrParseArgs) + -- TODO: Disabled for now because it may not be necessary {- , option [] ["independent-goals"] "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." - getig setig + (fmap asBool . getig) + (setig . fmap IndependentGoals) (yesNoOpt showOrParseArgs) -} , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." - getsip setsip + (fmap asBool . getsip) + (setsip . fmap ShadowPkgs) (yesNoOpt showOrParseArgs) , option [] ["strong-flags"] "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." - getstrfl setstrfl + (fmap asBool . getstrfl) + (setstrfl . fmap StrongFlags) (yesNoOpt showOrParseArgs) + , option [] ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) + (yesNoOpt showOrParseArgs) ] usageFlagsOrPackages :: String -> String -> String @@ -2137,8 +2466,8 @@ where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of - Version [] _ -> Dependency (packageName p) anyVersion - version -> Dependency (packageName p) (thisVersion version) + v | v == nullVersion -> Dependency (packageName p) anyVersion + | otherwise -> Dependency (packageName p) (thisVersion v) showRepo :: RemoteRepo -> String showRepo repo = remoteRepoName repo ++ ":" diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.SetupWrapper @@ -16,28 +17,36 @@ -- runs it with the given arguments. module Distribution.Client.SetupWrapper ( - setupWrapper, + getSetup, runSetup, runSetupCommand, setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version - ( Version(..), VersionRange, anyVersion + ( Version, mkVersion, versionNumbers, VersionRange, anyVersion , intersectVersionRanges, orLaterVersion , withinRange ) -import Distribution.InstalledPackageInfo (installedUnitId) +import qualified Distribution.Backpack as Backpack import Distribution.Package - ( UnitId(..), PackageIdentifier(..), PackageId, - PackageName(..), Package(..), packageName - , packageVersion, Dependency(..) ) + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName + , PackageIdentifier(..), packageVersion, packageName ) +import Distribution.Types.Dependency import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) , PackageDescription(..), specVersion , BuildType(..), knownBuildTypes, defaultRenaming ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +#else import Distribution.PackageDescription.Parse - ( readPackageDescription ) + ( readGenericPackageDescription ) +#endif import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Compiler @@ -49,11 +58,11 @@ import Distribution.Simple.Build.Macros ( generatePackageVersionMacros ) import Distribution.Simple.Program - ( ProgramConfiguration, emptyProgramConfiguration + ( ProgramDb, emptyProgramDb , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram , ghcjsProgram ) import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar ) + ( programSearchPathAsPATHVar, ProgramSearchPathEntry(ProgramSearchPathDir) ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip @@ -66,6 +75,8 @@ ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Client.Types import Distribution.Client.Config ( defaultCabalDir ) import Distribution.Client.IndexUtils @@ -75,39 +86,36 @@ import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Simple.Utils - ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing + ( die', debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile - , copyFileVerbose, rewriteFile, intercalate ) + , copyFileVerbose, rewriteFileEx ) import Distribution.Client.Utils - ( inDir, tryCanonicalizePath - , existsAndIsMoreRecentThan, moreRecentFile -#if mingw32_HOST_OS + ( inDir, tryCanonicalizePath, withExtraPathEnv + , existsAndIsMoreRecentThan, moreRecentFile, withEnv +#ifdef mingw32_HOST_OS , canonicalizePathNoThrow #endif ) + +import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text ( display ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity - ( Verbosity ) import Distribution.Compat.Exception ( catchIO ) +import Distribution.Compat.Stack import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) import System.Exit ( ExitCode(..), exitWith ) -import System.Process ( runProcess, waitForProcess ) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ( (<$>), (<*>) ) -import Data.Monoid ( mempty ) -#endif -import Control.Monad ( when, unless ) -import Data.List ( find, foldl1' ) -import Data.Maybe ( fromMaybe, isJust ) -import Data.Char ( isSpace ) +import System.Process ( createProcess, StdStream(..), proc, waitForProcess + , ProcessHandle ) +import qualified System.Process as Process +import Data.List ( foldl1' ) import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) #ifdef mingw32_HOST_OS @@ -120,6 +128,25 @@ import qualified System.Win32 as Win32 #endif +-- | @Setup@ encapsulates the outcome of configuring a setup method to build a +-- particular package. +data Setup = Setup { setupMethod :: SetupMethod + , setupScriptOptions :: SetupScriptOptions + , setupVersion :: Version + , setupBuildType :: BuildType + , setupPackage :: PackageDescription + } + +-- | @SetupMethod@ represents one of the methods used to run Cabal commands. +data SetupMethod = InternalMethod + -- ^ run Cabal commands through \"cabal\" in the + -- current process + | SelfExecMethod + -- ^ run Cabal commands through \"cabal\" as a + -- child process + | ExternalMethod FilePath + -- ^ run Cabal commands through a custom \"Setup\" executable + --TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the -- explicit options, and an optional initial part that applies certain @@ -129,6 +156,8 @@ -- -- See also the discussion at https://github.com/haskell/cabal/pull/3094 +-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as +-- opposed to options given to the Cabal command at runtime. data SetupScriptOptions = SetupScriptOptions { -- | The version of the Cabal library to use (if 'useDependenciesExclusive' -- is not set). A suitable version of the Cabal library must be installed @@ -155,14 +184,16 @@ usePlatform :: Maybe Platform, usePackageDB :: PackageDBStack, usePackageIndex :: Maybe InstalledPackageIndex, - useProgramConfig :: ProgramConfiguration, + useProgramDb :: ProgramDb, useDistPref :: FilePath, useLoggingHandle :: Maybe Handle, useWorkingDir :: Maybe FilePath, + -- | Extra things to add to PATH when invoking the setup script. + useExtraPathEnv :: [FilePath], forceExternalSetupMethod :: Bool, -- | List of dependencies to use when building Setup.hs. - useDependencies :: [(UnitId, PackageId)], + useDependencies :: [(ComponentId, PackageId)], -- | Is the list of setup dependencies exclusive? -- @@ -209,7 +240,12 @@ -- version) combination the cache holds a compiled setup script -- executable. This only affects the Simple build type; for the Custom, -- Configure and Make build types we always compile the setup script anew. - setupCacheLock :: Maybe Lock + setupCacheLock :: Maybe Lock, + + -- | Is the task we are going to run an interactive foreground task, + -- or an non-interactive background task? Based on this flag we + -- decide whether or not to delegate ctrl+c to the spawned task + isInteractive :: Bool } defaultSetupScriptOptions :: SetupScriptOptions @@ -223,88 +259,170 @@ useDependencies = [], useDependenciesExclusive = False, useVersionMacros = False, - useProgramConfig = emptyProgramConfiguration, + useProgramDb = emptyProgramDb, useDistPref = defaultDistPref, useLoggingHandle = Nothing, useWorkingDir = Nothing, + useExtraPathEnv = [], useWin32CleanHack = False, forceExternalSetupMethod = False, - setupCacheLock = Nothing + setupCacheLock = Nothing, + isInteractive = False } -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -> [String] - -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do +workingDir :: SetupScriptOptions -> FilePath +workingDir options = + case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + +-- | A @SetupRunner@ implements a 'SetupMethod'. +type SetupRunner = Verbosity + -> SetupScriptOptions + -> BuildType + -> [String] + -> IO () + +-- | Prepare to build a package by configuring a 'SetupMethod'. The returned +-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed +-- during the configuration process; the final values are given by +-- 'setupScriptOptions'. +getSetup :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> IO Setup +getSetup verbosity options mpkg = do pkg <- maybe getPkg return mpkg - let setupMethod = determineSetupMethod options' buildType' - options' = options { + let options' = options { useCabalVersion = intersectVersionRanges (useCabalVersion options) (orLaterVersion (specVersion pkg)) } buildType' = fromMaybe Custom (buildType pkg) - mkArgs cabalLibVersion = commandName cmd - : commandShowOptions cmd (flags cabalLibVersion) - ++ extraArgs checkBuildType buildType' - setupMethod verbosity options' (packageId pkg) buildType' mkArgs + (version, method, options'') <- + getSetupMethod verbosity options' pkg buildType' + return Setup { setupMethod = method + , setupScriptOptions = options'' + , setupVersion = version + , setupBuildType = buildType' + , setupPackage = pkg + } where getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options)) - >>= readPackageDescription verbosity + >>= readGenericPackageDescription verbosity >>= return . packageDescription checkBuildType (UnknownBuildType name) = - die $ "The build-type '" ++ name ++ "' is not known. Use one of: " + die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: " ++ intercalate ", " (map display knownBuildTypes) ++ "." checkBuildType _ = return () + -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. -- -determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod -determineSetupMethod options buildType' - -- This order is picked so that it's stable. The build type and - -- required cabal version are external info, coming from .cabal - -- files and the command line. Those do switch between the - -- external and self & internal methods, but that info itself can - -- be considered stable. The logging and force-external conditions - -- are internally generated choices but now these only switch - -- between the self and internal setup methods, which are - -- consistent with each other. - | buildType' == Custom = externalSetupMethod - | maybe False (cabalVersion /=) - (useCabalSpecVersion options) - || not (cabalVersion `withinRange` - useCabalVersion options) = externalSetupMethod +getSetupMethod + :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + -> IO (Version, SetupMethod, SetupScriptOptions) +getSetupMethod verbosity options pkg buildType' + | buildType' == Custom + || maybe False (cabalVersion /=) (useCabalSpecVersion options) + || not (cabalVersion `withinRange` useCabalVersion options) = + getExternalSetupMethod verbosity options pkg buildType' | isJust (useLoggingHandle options) -- Forcing is done to use an external process e.g. due to parallel -- build concerns. - || forceExternalSetupMethod options = selfExecSetupMethod - | otherwise = internalSetupMethod + || forceExternalSetupMethod options = + return (cabalVersion, SelfExecMethod, options) + | otherwise = return (cabalVersion, InternalMethod, options) -type SetupMethod = Verbosity - -> SetupScriptOptions - -> PackageIdentifier - -> BuildType - -> (Version -> [String]) -> IO () +runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) +runSetupMethod InternalMethod = internalSetupMethod +runSetupMethod (ExternalMethod path) = externalSetupMethod path +runSetupMethod SelfExecMethod = selfExecSetupMethod +-- | Run a configured 'Setup' with specific arguments. +runSetup :: Verbosity -> Setup + -> [String] -- ^ command-line arguments + -> IO () +runSetup verbosity setup args0 = do + let method = setupMethod setup + options = setupScriptOptions setup + bt = setupBuildType setup + args = verbosityHack (setupVersion setup) args0 + when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ + infoNoWrap verbose $ + "Applied verbosity hack:\n" ++ + " Before: " ++ show args0 ++ "\n" ++ + " After: " ++ show args ++ "\n" + runSetupMethod method verbosity options bt args + +-- | This is a horrible hack to make sure passing fancy verbosity +-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on +-- old Setup. We can't do it in 'filterConfigureFlags' because +-- verbosity applies to ALL commands. +verbosityHack :: Version -> [String] -> [String] +verbosityHack ver args0 + | ver >= mkVersion [1,25] = args0 + | otherwise = go args0 + where + go (('-':'v':rest) : args) + | Just rest' <- munch rest = ("-v" ++ rest') : go args + go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) + | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args + go ("--verbose" : rest : args) + | Just rest' <- munch rest = "--verbose" : rest' : go args + go rest@("--" : _) = rest + go (arg:args) = arg : go args + go [] = [] + + munch rest = + case runReadE flagToVerbosity rest of + Right v | verboseHasFlags v + -- We could preserve the prefix, but since we're assuming + -- it's Cabal's verbosity flag, we can assume that + -- any format is OK + -> Just (showForCabal (verboseNoFlags v)) + _ -> Nothing + +-- | Run a command through a configured 'Setup'. +runSetupCommand :: Verbosity -> Setup + -> CommandUI flags -- ^ command definition + -> flags -- ^ command flags + -> [String] -- ^ extra command-line arguments + -> IO () +runSetupCommand verbosity setup cmd flags extraArgs = do + let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs + runSetup verbosity setup args + +-- | Configure a 'Setup' and run a command in one step. The command flags +-- may depend on the Cabal library version in use. +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -- ^ produce command flags given the Cabal library version + -> [String] + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + setup <- getSetup verbosity options mpkg + runSetupCommand verbosity setup cmd (flags $ setupVersion setup) extraArgs + -- ------------------------------------------------------------ -- * Internal SetupMethod -- ------------------------------------------------------------ -internalSetupMethod :: SetupMethod -internalSetupMethod verbosity options _ bt mkargs = do - let args = mkargs cabalVersion - debug verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ - buildTypeAction bt args +internalSetupMethod :: SetupRunner +internalSetupMethod verbosity options bt args = do + info verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ do + withEnv "HASKELL_DIST_DIR" (useDistPref options) $ + withExtraPathEnv (useExtraPathEnv options) $ + buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple = Simple.defaultMainArgs @@ -314,16 +432,46 @@ buildTypeAction Custom = error "buildTypeAction Custom" buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" + +-- | @runProcess'@ is a version of @runProcess@ where we have +-- the additional option to decide whether or not we should +-- delegate CTRL+C to the spawned process. +runProcess' :: FilePath -- ^ Filename of the executable + -> [String] -- ^ Arguments to pass to executable + -> Maybe FilePath -- ^ Optional path to working directory + -> Maybe [(String, String)] -- ^ Optional environment + -> Maybe Handle -- ^ Handle for @stdin@ + -> Maybe Handle -- ^ Handle for @stdout@ + -> Maybe Handle -- ^ Handle for @stderr@ + -> Bool -- ^ Delegate Ctrl+C ? + -> IO ProcessHandle +runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do + (_,_,_,ph) <- + createProcess + (proc cmd args){ Process.cwd = mb_cwd + , Process.env = mb_env + , Process.std_in = mbToStd mb_stdin + , Process.std_out = mbToStd mb_stdout + , Process.std_err = mbToStd mb_stderr +#if MIN_VERSION_process(1,2,0) + , Process.delegate_ctlc = _delegate +#endif + } + return ph + where + mbToStd :: Maybe Handle -> StdStream + mbToStd Nothing = Inherit + mbToStd (Just hdl) = UseHandle hdl -- ------------------------------------------------------------ -- * Self-Exec SetupMethod -- ------------------------------------------------------------ -selfExecSetupMethod :: SetupMethod -selfExecSetupMethod verbosity options _pkg bt mkargs = do +selfExecSetupMethod :: SetupRunner +selfExecSetupMethod verbosity options bt args0 = do let args = ["act-as-setup", "--build-type=" ++ display bt, - "--"] ++ mkargs cabalVersion - debug verbosity $ "Using self-exec internal setup method with build-type " + "--"] ++ args0 + info verbosity $ "Using self-exec internal setup method with build-type " ++ show bt ++ " and args:\n " ++ show args path <- getExecutablePath info verbosity $ unwords (path : args) @@ -333,12 +481,14 @@ ++ show logHandle searchpath <- programSearchPathAsPATHVar - (getProgramSearchPath (useProgramConfig options)) - env <- getEffectiveEnvironment [("PATH", Just searchpath)] - - process <- runProcess path args + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment [("PATH", Just searchpath) + ,("HASKELL_DIST_DIR", Just (useDistPref options))] + process <- runProcess' path args (useWorkingDir options) env Nothing (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode @@ -346,8 +496,62 @@ -- * External SetupMethod -- ------------------------------------------------------------ -externalSetupMethod :: SetupMethod -externalSetupMethod verbosity options pkg bt mkargs = do +externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) +externalSetupMethod path verbosity options _ args = do + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + if useWin32CleanHack options then doWin32CleanHack path else doInvoke path +#else + doInvoke path +#endif + + where + doInvoke path' = do + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment [("PATH", Just searchpath) + ,("HASKELL_DIST_DIR", Just (useDistPref options))] + + process <- runProcess' path' args + (useWorkingDir options) env Nothing + (useLoggingHandle options) (useLoggingHandle options) + (isInteractive options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +#ifdef mingw32_HOST_OS + doWin32CleanHack path' = do + info verbosity $ "Using the Win32 clean hack." + -- Recursively removes the temp dir on exit. + withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> + bracket (moveOutOfTheWay tmpDir path') + (maybeRestore path') + doInvoke + + moveOutOfTheWay tmpDir path' = do + let newPath = tmpDir "setup" <.> exeExtension + Win32.moveFile path' newPath + return newPath + + maybeRestore oldPath path' = do + let oldPathDir = takeDirectory oldPath + oldPathDirExists <- doesDirectoryExist oldPathDir + -- 'setup clean' didn't complete, 'dist/setup' still exists. + when oldPathDirExists $ + Win32.moveFile path' oldPath +#endif + +getExternalSetupMethod + :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType + -> IO (Version, SetupMethod, SetupScriptOptions) +getExternalSetupMethod verbosity options pkg bt = do debug verbosity $ "Using external setup method with build-type " ++ show bt debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options) @@ -359,13 +563,29 @@ cabalLibVersion mCabalLibInstalledPkgId else compileSetupExecutable options' cabalLibVersion mCabalLibInstalledPkgId False - invokeSetupScript options' path (mkargs cabalLibVersion) + -- Since useWorkingDir can change the relative path, the path argument must + -- be turned into an absolute path. On some systems, runProcess' will take + -- path as relative to the new working directory instead of the current + -- working directory. + path' <- tryCanonicalizePath path + + -- See 'Note: win32 clean hack' above. +#ifdef mingw32_HOST_OS + -- setupProgFile may not exist if we're using a cached program + setupProgFile' <- canonicalizePathNoThrow setupProgFile + let win32CleanHackNeeded = (useWin32CleanHack options) + -- Skip when a cached setup script is used. + && setupProgFile' `equalFilePath` path' +#else + let win32CleanHackNeeded = False +#endif + let options'' = options' { useWin32CleanHack = win32CleanHackNeeded } + + return (cabalLibVersion, ExternalMethod path', options'') + where - workingDir = case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir - setupDir = workingDir useDistPref options "setup" + setupDir = workingDir options useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" setupHs = setupDir "setup" <.> "hs" setupProgFile = setupDir "setup" <.> exeExtension @@ -374,12 +594,12 @@ useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) maybeGetInstalledPackages :: SetupScriptOptions -> Compiler - -> ProgramConfiguration -> IO InstalledPackageIndex - maybeGetInstalledPackages options' comp conf = + -> ProgramDb -> IO InstalledPackageIndex + maybeGetInstalledPackages options' comp progdb = case usePackageIndex options' of Just index -> return index Nothing -> getInstalledPackages verbosity - comp (usePackageDB options') conf + comp (usePackageDB options') progdb -- Choose the version of Cabal to use if the setup script has a dependency on -- Cabal, and possibly update the setup script options. The version also @@ -393,10 +613,10 @@ -- -- The version chosen here must match the one used in 'compileSetupExecutable' -- (See issue #3433). - cabalLibVersionToUse :: IO (Version, Maybe UnitId + cabalLibVersionToUse :: IO (Version, Maybe ComponentId ,SetupScriptOptions) cabalLibVersionToUse = - case find (hasCabal . snd) (useDependencies options) of + case find (isCabalPkgId . snd) (useDependencies options) of Just (unitId, pkgId) -> do let version = pkgVersion pkgId updateSetupScript version bt @@ -439,14 +659,11 @@ writeSetupVersionFile version = writeFile setupVersionFile (show version ++ "\n") - hasCabal (PackageIdentifier (PackageName "Cabal") _) = True - hasCabal _ = False - - installedVersion :: IO (Version, Maybe UnitId + installedVersion :: IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) installedVersion = do - (comp, conf, options') <- configureCompiler options - (version, mipkgid, options'') <- installedCabalVersion options' comp conf + (comp, progdb, options') <- configureCompiler options + (version, mipkgid, options'') <- installedCabalVersion options' comp progdb updateSetupScript version bt writeSetupVersionFile version return (version, mipkgid, options'') @@ -463,7 +680,7 @@ updateSetupScript _ Custom = do useHs <- doesFileExist customSetupHs useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ die + unless (useHs || useLhs) $ die' verbosity "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." let src = (if useHs then customSetupHs else customSetupLhs) srcNewer <- src `moreRecentFile` setupHs @@ -471,38 +688,38 @@ then copyFileVerbose verbosity src setupHs else runSimplePreProcessor ppUnlit src setupHs verbosity where - customSetupHs = workingDir "Setup.hs" - customSetupLhs = workingDir "Setup.lhs" + customSetupHs = workingDir options "Setup.hs" + customSetupLhs = workingDir options "Setup.lhs" updateSetupScript cabalLibVersion _ = - rewriteFile setupHs (buildTypeScript cabalLibVersion) + rewriteFileEx verbosity setupHs (buildTypeScript cabalLibVersion) buildTypeScript :: Version -> String buildTypeScript cabalLibVersion = case bt of Simple -> "import Distribution.Simple; main = defaultMain\n" Configure -> "import Distribution.Simple; main = defaultMainWithHooks " - ++ if cabalLibVersion >= Version [1,3,10] [] + ++ if cabalLibVersion >= mkVersion [1,3,10] then "autoconfUserHooks\n" else "defaultUserHooks\n" Make -> "import Distribution.Make; main = defaultMain\n" Custom -> error "buildTypeScript Custom" UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" - installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration - -> IO (Version, Maybe UnitId + installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb + -> IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) - installedCabalVersion options' compiler conf = do - index <- maybeGetInstalledPackages options' compiler conf - let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options') + installedCabalVersion options' compiler progdb = do + index <- maybeGetInstalledPackages options' compiler progdb + let cabalDep = Dependency (mkPackageName "Cabal") (useCabalVersion options') options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package '" ++ display (packageName pkg) + [] -> die' verbosity $ "The package '" ++ display (packageName pkg) ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs in return (packageVersion ipkginfo - ,Just . installedUnitId $ ipkginfo, options'') + ,Just . IPI.installedComponentId $ ipkginfo, options'') bestVersion :: (a -> Version) -> [a] -> a bestVersion f = firstMaximumBy (comparing (preference . f)) @@ -528,27 +745,27 @@ where sameVersion = version == cabalVersion sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionBranch - stableVersion = case versionBranch version of + majorVersion = take 2 . versionNumbers + stableVersion = case versionNumbers version of (_:x:_) -> even x _ -> False latestVersion = version configureCompiler :: SetupScriptOptions - -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) + -> IO (Compiler, ProgramDb, SetupScriptOptions) configureCompiler options' = do - (comp, conf) <- case useCompiler options' of - Just comp -> return (comp, useProgramConfig options') - Nothing -> do (comp, _, conf) <- + (comp, progdb) <- case useCompiler options' of + Just comp -> return (comp, useProgramDb options') + Nothing -> do (comp, _, progdb) <- configCompilerEx (Just GHC) Nothing Nothing - (useProgramConfig options') verbosity - return (comp, conf) + (useProgramDb options') verbosity + return (comp, progdb) -- Whenever we need to call configureCompiler, we also need to access the -- package index, so let's cache it in SetupScriptOptions. - index <- maybeGetInstalledPackages options' comp conf - return (comp, conf, options' { useCompiler = Just comp, - usePackageIndex = Just index, - useProgramConfig = conf }) + index <- maybeGetInstalledPackages options' comp progdb + return (comp, progdb, options' { useCompiler = Just comp, + usePackageIndex = Just index, + useProgramDb = progdb }) -- | Path to the setup exe cache directory and path to the cached setup -- executable. @@ -575,7 +792,7 @@ -- | Look up the setup executable in the cache; update the cache if the setup -- executable is not found. getCachedSetupExecutable :: SetupScriptOptions - -> Version -> Maybe UnitId + -> Version -> Maybe InstalledPackageId -> IO FilePath getCachedSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId = do @@ -599,7 +816,7 @@ installExecutableFile verbosity src cachedSetupProgFile -- Do not strip if we're using GHCJS, since the result may be a script when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $ - Strip.stripExe verbosity platform (useProgramConfig options') + Strip.stripExe verbosity platform (useProgramDb options') cachedSetupProgFile return cachedSetupProgFile where @@ -610,7 +827,7 @@ -- Currently this is GHC/GHCJS only. It should really be generalised. -- compileSetupExecutable :: SetupScriptOptions - -> Version -> Maybe UnitId -> Bool + -> Version -> Maybe ComponentId -> Bool -> IO FilePath compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId forceCompile = do @@ -619,8 +836,8 @@ let outOfDate = setupHsNewer || cabalVersionNewer when (outOfDate || forceCompile) $ do debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, conf, options'') <- configureCompiler options' - let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + (compiler, progdb, options'') <- configureCompiler options' + let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion (program, extraOpts) = case compilerFlavor compiler of GHCJS -> (ghcjsProgram, ["-build-runner"]) @@ -638,19 +855,20 @@ -- Both of these options should be enabled for packages that have -- opted-in and declared a custom-settup stanza. -- - hasCabal (_, PackageIdentifier (PackageName "Cabal") _) = True - hasCabal _ = False - selectedDeps | useDependenciesExclusive options' = useDependencies options' | otherwise = useDependencies options' ++ - if any hasCabal (useDependencies options') + if any (isCabalPkgId . snd) (useDependencies options') then [] else cabalDep - addRenaming (ipid, pid) = (ipid, pid, defaultRenaming) + addRenaming (ipid, _) = + -- Assert 'DefUnitId' invariant + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { - ghcOptVerbosity = Flag verbosity + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = Flag (min verbosity normal) , ghcOptMode = Flag GhcModeMake , ghcOptInputFiles = toNubListR [setupHs] , ghcOptOutputFile = Flag setupProgFile @@ -658,7 +876,7 @@ , ghcOptHiDir = Flag setupDir , ghcOptSourcePathClear = Flag True , ghcOptSourcePath = case bt of - Custom -> toNubListR [workingDir] + Custom -> toNubListR [workingDir options'] _ -> mempty , ghcOptPackageDBs = usePackageDB options'' , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') @@ -670,73 +888,17 @@ } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions when (useVersionMacros options') $ - rewriteFile cppMacrosFile (generatePackageVersionMacros - [ pid | (_ipid, pid) <- selectedDeps ]) + rewriteFileEx verbosity cppMacrosFile + (generatePackageVersionMacros (map snd selectedDeps)) case useLoggingHandle options of - Nothing -> runDbProgram verbosity program conf ghcCmdLine + Nothing -> runDbProgram verbosity program progdb ghcCmdLine -- If build logging is enabled, redirect compiler output to the log file. (Just logHandle) -> do output <- getDbProgramOutput verbosity program - conf ghcCmdLine + progdb ghcCmdLine hPutStr logHandle output return setupProgFile - invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO () - invokeSetupScript options' path args = do - info verbosity $ unwords (path : args) - case useLoggingHandle options' of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - -- Since useWorkingDir can change the relative path, the path argument must - -- be turned into an absolute path. On some systems, runProcess will take - -- path as relative to the new working directory instead of the current - -- working directory. - path' <- tryCanonicalizePath path - - -- See 'Note: win32 clean hack' above. -#if mingw32_HOST_OS - -- setupProgFile may not exist if we're using a cached program - setupProgFile' <- canonicalizePathNoThrow setupProgFile - let win32CleanHackNeeded = (useWin32CleanHack options') - -- Skip when a cached setup script is used. - && setupProgFile' `equalFilePath` path' - if win32CleanHackNeeded then doWin32CleanHack path' else doInvoke path' -#else - doInvoke path' -#endif - - where - doInvoke path' = do - searchpath <- programSearchPathAsPATHVar - (getProgramSearchPath (useProgramConfig options')) - env <- getEffectiveEnvironment [("PATH", Just searchpath)] - - process <- runProcess path' args - (useWorkingDir options') env Nothing - (useLoggingHandle options') (useLoggingHandle options') - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode - -#if mingw32_HOST_OS - doWin32CleanHack path' = do - info verbosity $ "Using the Win32 clean hack." - -- Recursively removes the temp dir on exit. - withTempDirectory verbosity workingDir "cabal-tmp" $ \tmpDir -> - bracket (moveOutOfTheWay tmpDir path') - (maybeRestore path') - doInvoke - - moveOutOfTheWay tmpDir path' = do - let newPath = tmpDir "setup" <.> exeExtension - Win32.moveFile path' newPath - return newPath - - maybeRestore oldPath path' = do - let oldPathDir = takeDirectory oldPath - oldPathDirExists <- doesDirectoryExist oldPathDir - -- 'setup clean' didn't complete, 'dist/setup' still exists. - when oldPathDirExists $ - Win32.moveFile path' oldPath -#endif +isCabalPkgId :: PackageIdentifier -> Bool +isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal" diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SolverInstallPlan.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SolverInstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'SolverInstallPlan' is the graph of packages produced by the +-- dependency solver, and specifies at the package-granularity what +-- things are going to be installed. To put it another way: the +-- dependency solver produces a 'SolverInstallPlan', which is then +-- consumed by various other parts of Cabal. +-- +----------------------------------------------------------------------------- +module Distribution.Client.SolverInstallPlan( + SolverInstallPlan(..), + SolverPlanPackage, + ResolverPackage(..), + + -- * Operations on 'SolverInstallPlan's + new, + toList, + toMap, + + remove, + + showPlanIndex, + showInstallPlan, + + -- * Checking validity of plans + valid, + closed, + consistent, + acyclic, + + -- ** Details on invalid plans + SolverPlanProblem(..), + showPlanProblem, + problems, + + -- ** Querying the install plan + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, +) where + +import Distribution.Package + ( PackageIdentifier(..), Package(..), PackageName + , HasUnitId(..), PackageId, packageVersion, packageName ) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Text + ( display ) + +import Distribution.Client.Types + ( UnresolvedPkgLoc ) +import Distribution.Version + ( Version ) + +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId + +import Data.List + ( intercalate ) +import Data.Maybe + ( fromMaybe, catMaybes ) +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Graph (Graph, IsNode(..)) +import qualified Data.Graph as OldGraph +import qualified Distribution.Compat.Graph as Graph +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Array ((!)) +import Data.Typeable + +type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc + +type SolverPlanIndex = Graph SolverPlanPackage + +data SolverInstallPlan = SolverInstallPlan { + planIndex :: !SolverPlanIndex, + planIndepGoals :: !IndependentGoals + } + deriving (Typeable) + +{- +-- | Much like 'planPkgIdOf', but mapping back to full packages. +planPkgOf :: SolverInstallPlan + -> Graph.Vertex + -> SolverPlanPackage +planPkgOf plan v = + case Graph.lookupKey (planIndex plan) + (planPkgIdOf plan v) of + Just pkg -> pkg + Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" +-} + +mkInstallPlan :: SolverPlanIndex + -> IndependentGoals + -> SolverInstallPlan +mkInstallPlan index indepGoals = + SolverInstallPlan { + planIndex = index, + planIndepGoals = indepGoals + } + +instance Binary SolverInstallPlan where + put SolverInstallPlan { + planIndex = index, + planIndepGoals = indepGoals + } = put (index, indepGoals) + + get = do + (index, indepGoals) <- get + return $! mkInstallPlan index indepGoals + +showPlanIndex :: [SolverPlanPackage] -> String +showPlanIndex = intercalate "\n" . map showPlanPackage + +showInstallPlan :: SolverInstallPlan -> String +showInstallPlan = showPlanIndex . toList + +showPlanPackage :: SolverPlanPackage -> String +showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg) + ++ " (" ++ display (installedUnitId ipkg) + ++ ")" +showPlanPackage (Configured spkg) = "Configured " ++ display (packageId spkg) + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: IndependentGoals + -> SolverPlanIndex + -> Either [SolverPlanProblem] SolverInstallPlan +new indepGoals index = + case problems indepGoals index of + [] -> Right (mkInstallPlan index indepGoals) + probs -> Left probs + +toList :: SolverInstallPlan -> [SolverPlanPackage] +toList = Graph.toList . planIndex + +toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage +toMap = Graph.toMap . planIndex + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (SolverPlanPackage -> Bool) + -> SolverInstallPlan + -> Either [SolverPlanProblem] + (SolverInstallPlan) +remove shouldRemove plan = + new (planIndepGoals plan) newIndex + where + newIndex = Graph.fromDistinctList $ + filter (not . shouldRemove) (toList plan) + +-- ------------------------------------------------------------ +-- * Checking validity of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: IndependentGoals + -> SolverPlanIndex + -> Bool +valid indepGoals index = + null $ problems indepGoals index + +data SolverPlanProblem = + PackageMissingDeps SolverPlanPackage + [PackageIdentifier] + | PackageCycle [SolverPlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid SolverPlanPackage SolverPlanPackage + +showPlanProblem :: SolverPlanProblem -> String +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (packageId pkg) + ++ " depends on the following packages which are missing from the plan: " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ display name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ display (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: IndependentGoals + -> SolverPlanIndex + -> [SolverPlanProblem] +problems indepGoals index = + + [ PackageMissingDeps pkg + (catMaybes + (map + (fmap packageId . flip Graph.lookup index) + missingDeps)) + | (pkg, missingDeps) <- Graph.broken index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- Graph.cycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- + dependencyInconsistencies indepGoals index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- Graph.toList index + , Just pkg' <- map (flip Graph.lookup index) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') ] + + +-- | Compute all roots of the install plan, and verify that the transitive +-- plans from those roots are all consistent. +-- +-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles +-- may be absent from the subplans even if the larger plan contains a dependency +-- cycle. Such cycles may or may not be an issue; either way, we don't check +-- for them here. +dependencyInconsistencies :: IndependentGoals + -> SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies indepGoals index = + concatMap dependencyInconsistencies' subplans + where + subplans :: [SolverPlanIndex] + subplans = -- Not Graph.closure!! + map (nonSetupClosure index) + (rootSets indepGoals index) + +-- NB: When we check for inconsistencies, packages from the setup +-- scripts don't count as part of the closure (this way, we +-- can build, e.g., Cabal-1.24.1 even if its setup script is +-- built with Cabal-1.24.0). +-- +-- This is a best effort function that swallows any non-existent +-- SolverIds. +nonSetupClosure :: SolverPlanIndex + -> [SolverId] + -> SolverPlanIndex +nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 + where + closure completed [] = completed + closure completed (pkgid:pkgids) = + case Graph.lookup pkgid index of + Nothing -> closure completed pkgids + Just pkg -> + case Graph.lookup (nodeKey pkg) completed of + Just _ -> closure completed pkgids + Nothing -> closure completed' pkgids' + where completed' = Graph.insert pkg completed + pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids + +-- | Compute the root sets of a plan +-- +-- A root set is a set of packages whose dependency closure must be consistent. +-- This is the set of all top-level library roots (taken together normally, or +-- as singletons sets if we are considering them as independent goals), along +-- with all setup dependencies of all packages. +rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] +rootSets (IndependentGoals indepGoals) index = + if indepGoals then map (:[]) libRoots else [libRoots] + ++ setupRoots index + where + libRoots = libraryRoots index + +-- | Compute the library roots of a plan +-- +-- The library roots are the set of packages with no reverse dependencies +-- (no reverse library dependencies but also no reverse setup dependencies). +libraryRoots :: SolverPlanIndex -> [SolverId] +libraryRoots index = + map (nodeKey . toPkgId) roots + where + (graph, toPkgId, _) = Graph.toGraph index + indegree = OldGraph.indegree graph + roots = filter isRoot (OldGraph.vertices graph) + isRoot v = indegree ! v == 0 + +-- | The setup dependencies of each package in the plan +setupRoots :: SolverPlanIndex -> [[SolverId]] +setupRoots = filter (not . null) + . map (CD.setupDeps . resolverPackageLibDeps) + . Graph.toList + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies' :: SolverPlanIndex + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies' index = + [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) + ] + where + -- For each package name (of a dependency, somewhere) + -- and each installed ID of that that package + -- the associated package instance + -- and a list of reverse dependencies (as source IDs) + inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) + inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) + | -- For each package @pkg@ + pkg <- Graph.toList index + -- Find out which @sid@ @pkg@ depends on + , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) + -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) + , Just dep <- [Graph.lookup sid index] + ] + + -- If, in a single install plan, we depend on more than one version of a + -- package, then this is ONLY okay in the (rather special) case that we + -- depend on precisely two versions of that package, and one of them + -- depends on the other. This is necessary for example for the base where + -- we have base-3 depending on base-4. + reallyIsInconsistent :: [SolverPlanPackage] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + let pid1 = nodeKey p1 + pid2 = nodeKey p2 + in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) + && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) + reallyIsInconsistent _ = True + + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: SolverPlanIndex -> Bool +acyclic = null . Graph.cycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: SolverPlanIndex -> Bool +closed = null . Graph.broken + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are OK so long as they are not both in the transitive closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe approximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: SolverPlanIndex -> Bool +consistent = null . dependencyInconsistencies (IndependentGoals False) + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: SolverPlanPackage + -> SolverPlanPackage + -> Bool +stateDependencyRelation PreExisting{} PreExisting{} = True + +stateDependencyRelation (Configured _) PreExisting{} = True +stateDependencyRelation (Configured _) (Configured _) = True + +stateDependencyRelation _ _ = False + + +-- | Compute the dependency closure of a package in a install plan +-- +dependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan) + + +reverseDependencyClosure :: SolverInstallPlan + -> [SolverId] + -> [SolverPlanPackage] +reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) + + +topologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +topologicalOrder plan = Graph.topSort (planIndex plan) + + +reverseTopologicalOrder :: SolverInstallPlan + -> [SolverPlanPackage] +reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) diff --git a/Distribution/Client/SourceFiles.hs b/Distribution/Client/SourceFiles.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SourceFiles.hs @@ -0,0 +1,168 @@ +-- | Contains an @sdist@ like function which computes the source files +-- that we should track to determine if a rebuild is necessary. +-- Unlike @sdist@, we can operate directly on the true +-- 'PackageDescription' (not flattened). +-- +-- The naming convention, roughly, is that to declare we need the +-- source for some type T, you use the function needT; some functions +-- need auxiliary information. +-- +-- We can only use this code for non-Custom scripts; Custom scripts +-- may have arbitrary extra dependencies (esp. new preprocessors) which +-- we cannot "see" easily. +module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Simple.PreProcess + +import Distribution.Types.PackageDescription +import Distribution.Types.Component +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Library +import Distribution.Types.Executable +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Types.BuildInfo +import Distribution.Types.ForeignLib + +import Distribution.ModuleName + +import Prelude () +import Distribution.Client.Compat.Prelude + +import System.FilePath +import Control.Monad +import qualified Data.Set as Set + +needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () +needElaboratedConfiguredPackage elab = + case elabPkgOrComp elab of + ElabComponent ecomp -> needElaboratedComponent elab ecomp + ElabPackage epkg -> needElaboratedPackage elab epkg + +needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () +needElaboratedPackage elab epkg = + mapM_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) + where + pkg_descr = elabPkgDescription elab + enabled_stanzas = pkgStanzasEnabled epkg + -- TODO: turn this into a helper function somewhere + enabled = + ComponentRequestedSpec { + testsRequested = TestStanzas `Set.member` enabled_stanzas, + benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas + } + +needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () +needElaboratedComponent elab ecomp = + case mb_comp of + Nothing -> needSetup + Just comp -> needComponent pkg_descr comp + where + pkg_descr = elabPkgDescription elab + mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) + +needComponent :: PackageDescription -> Component -> Rebuild () +needComponent pkg_descr comp = + case comp of + CLib lib -> needLibrary pkg_descr lib + CFLib flib -> needForeignLib pkg_descr flib + CExe exe -> needExecutable pkg_descr exe + CTest test -> needTestSuite pkg_descr test + CBench bench -> needBenchmark pkg_descr bench + +needSetup :: Rebuild () +needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () + +needLibrary :: PackageDescription -> Library -> Rebuild () +needLibrary pkg_descr (Library { exposedModules = modules + , signatures = sigs + , libBuildInfo = bi }) + = needBuildInfo pkg_descr bi (modules ++ sigs) + +needForeignLib :: PackageDescription -> ForeignLib -> Rebuild () +needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs + , foreignLibBuildInfo = bi }) + = do mapM_ needIfExists fs + needBuildInfo pkg_descr bi [] + +needExecutable :: PackageDescription -> Executable -> Rebuild () +needExecutable pkg_descr (Executable { modulePath = mainPath + , buildInfo = bi }) + = do needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + +needTestSuite :: PackageDescription -> TestSuite -> Rebuild () +needTestSuite pkg_descr t + = case testInterface t of + TestSuiteExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + TestSuiteLibV09 _ m -> + needBuildInfo pkg_descr bi [m] + TestSuiteUnsupported _ -> return () -- soft fail + where + bi = testBuildInfo t + +needMainFile :: BuildInfo -> FilePath -> Rebuild () +needMainFile bi mainPath = do + -- The matter here is subtle. It might *seem* that we + -- should just search for mainPath, but as per + -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' + -- will actually be the source file AFTER preprocessing, + -- whereas we need to get the file *prior* to preprocessing. + ppFile <- findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + -- But check the original path in the end, because + -- maybe it's a non-preprocessed file with a non-traditional + -- extension. + Nothing -> findFileMonitored (hsSourceDirs bi) mainPath + >>= maybe (return ()) need + Just pp -> need pp + +needBenchmark :: PackageDescription -> Benchmark -> Rebuild () +needBenchmark pkg_descr bm + = case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + BenchmarkUnsupported _ -> return () -- soft fail + where + bi = benchmarkBuildInfo bm + +needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () +needBuildInfo pkg_descr bi modules = do + -- NB: These are separate because there may be both A.hs and + -- A.hs-boot; need to track both. + findNeededModules ["hs", "lhs", "hsig", "lhsig"] + findNeededModules ["hs-boot", "lhs-boot"] + mapM_ needIfExists (cSources bi ++ jsSources bi) + -- A MASSIVE HACK to (1) make sure we rebuild when header + -- files change, but (2) not have to rebuild when anything + -- in extra-src-files changes (most of these won't affect + -- compilation). It would be even better if we knew on a + -- per-component basis which headers would be used but that + -- seems to be too difficult. + mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr)) + forM_ (installIncludes bi) $ \f -> + findFileMonitored ("." : includeDirs bi) f + >>= maybe (return ()) need + where + findNeededModules exts = + mapM_ (findNeededModule exts) + (modules ++ otherModules bi) + findNeededModule exts m = + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers ++ exts) + (hsSourceDirs bi) + (toFilePath m) + >>= maybe (return ()) need diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE FlexibleContexts #-} -- Implements the \"@.\/cabal sdist@\" command, which creates a source -- distribution for this package. That is, packs up the source code -- into a tarball, making use of the corresponding Cabal module. @@ -18,11 +20,16 @@ ( PackageDescription ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) +#else import Distribution.PackageDescription.Parse - ( readPackageDescription ) + ( readGenericPackageDescription ) +#endif import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc - , warn, die, notice, withTempDirectory ) + , warn, die', notice, withTempDirectory ) import Distribution.Client.Setup ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup @@ -33,7 +40,7 @@ import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display ) import Distribution.Verbosity (Verbosity, normal, lessVerbose) -import Distribution.Version (Version(..), orLaterVersion) +import Distribution.Version (mkVersion, orLaterVersion, intersectVersionRanges) import Distribution.Client.Utils (tryFindAddSourcePackageDesc) @@ -50,8 +57,9 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do pkg <- liftM flattenPackageDescription - (readPackageDescription verbosity =<< defaultPackageDesc verbosity) - let withDir = if not needMakeArchive then (\f -> f tmpTargetDir) + (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity) + let withDir :: (FilePath -> IO a) -> IO a + withDir = if not needMakeArchive then \f -> f tmpTargetDir else withTempDirectory verbosity tmpTargetDir "sdist." -- 'withTempDir' fails if we don't create 'tmpTargetDir'... when needMakeArchive $ @@ -94,8 +102,8 @@ -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and -- '--list-sources' in 1.17. useCabalVersion = if isListSources - then orLaterVersion $ Version [1,17,0] [] - else orLaterVersion $ Version [1,12,0] [] + then orLaterVersion $ mkVersion [1,17,0] + else orLaterVersion $ mkVersion [1,12,0] } format = fromFlag (sDistFormat exflags) createArchive = case format of @@ -140,7 +148,7 @@ Nothing Nothing Nothing Nothing exitCode <- waitForProcess hnd unless (exitCode == ExitSuccess) $ - die $ "Generating the zip file failed " + die' verbosity $ "Generating the zip file failed " ++ "(zip returned exit code " ++ show exitCode ++ ")" notice verbosity $ "Source zip archive created: " ++ zipfile where @@ -148,12 +156,13 @@ -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory). -allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] -allPackageSourceFiles verbosity packageDir = do +allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath + -> IO [FilePath] +allPackageSourceFiles verbosity setupOpts0 packageDir = do pkg <- do let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc packageDir err - flattenPackageDescription `fmap` readPackageDescription verbosity desc + desc <- tryFindAddSourcePackageDesc verbosity packageDir err + flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc globalTmp <- getTemporaryDirectory withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do let file = tempDir "cabal-sdist-list-sources" @@ -162,9 +171,11 @@ then lessVerbose verbosity else verbosity, sDistListSources = Flag file } - setupOpts = defaultSetupScriptOptions { + setupOpts = setupOpts0 { -- 'sdist --list-sources' was introduced in Cabal 1.18. - useCabalVersion = orLaterVersion $ Version [1,18,0] [], + useCabalVersion = intersectVersionRanges + (orLaterVersion $ mkVersion [1,18,0]) + (useCabalVersion setupOpts0), useWorkingDir = Just packageDir } diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Store.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + + +-- | Management for the installed package store. +-- +module Distribution.Client.Store ( + + -- * The store layout + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * Reading store entries + getStoreEntries, + doesStoreEntryExist, + + -- * Creating store entries + newStoreEntry, + NewStoreEntryOutcome(..), + + -- * Concurrency strategy + -- $concurrency + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.FileLock + +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId) + +import Distribution.Simple.Utils + ( withTempDirectory, debug, info ) +import Distribution.Verbosity +import Distribution.Text + +import Data.Set (Set) +import qualified Data.Set as Set +import Control.Exception +import System.FilePath +import System.Directory +import System.IO + + +-- $concurrency +-- +-- We access and update the store concurrently. Our strategy to do that safely +-- is as follows. +-- +-- The store entries once created are immutable. This alone simplifies matters +-- considerably. +-- +-- Additionally, the way 'UnitId' hashes are constructed means that if a store +-- entry exists already then we can assume its content is ok to reuse, rather +-- than having to re-recreate. This is the nix-style input hashing concept. +-- +-- A consequence of this is that with a little care it is /safe/ to race +-- updates against each other. Consider two independent concurrent builds that +-- both want to build a particular 'UnitId', where that entry does not yet +-- exist in the store. It is safe for both to build and try to install this +-- entry into the store provided that: +-- +-- * only one succeeds +-- * the looser discovers that they lost, they abandon their own build and +-- re-use the store entry installed by the winner. +-- +-- Note that because builds are not reproducible in general (nor even +-- necessarily ABI compatible) then it is essential that the loser abandon +-- their build and use the one installed by the winner, so that subsequent +-- packages are built against the exact package from the store rather than some +-- morally equivalent package that may not be ABI compatible. +-- +-- Our overriding goal is that store reads be simple, cheap and not require +-- locking. We will derive our write-side protocol to make this possible. +-- +-- The read-side protocol is simply: +-- +-- * check for the existence of a directory entry named after the 'UnitId' in +-- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then +-- the store entry can be assumed to be complete and immutable. +-- +-- Given our read-side protocol, the final step on the write side must be to +-- atomically rename a fully-formed store entry directory into its final +-- location. While this will indeed be the final step, the preparatory steps +-- are more complicated. The tricky aspect is that the store also contains a +-- number of shared package databases (one per compiler version). Our read +-- strategy means that by the time we install the store dir entry the package +-- db must already have been updated. We cannot do the package db update +-- as part of atomically renaming the store entry directory however. Furthermore +-- it is not safe to allow either package db update because the db entry +-- contains the ABI hash and this is not guaranteed to be deterministic. So we +-- must register the new package prior to the atomic dir rename. Since this +-- combination of steps are not atomic then we need locking. +-- +-- The write-side protocol is: +-- +-- * Create a unique temp dir and write all store entry files into it. +-- +-- * Take a lock named after the 'UnitId' in question. +-- +-- * Once holding the lock, check again for the existence of the final store +-- entry directory. If the entry exists then the process lost the race and it +-- must abandon, unlock and re-use the existing store entry. If the entry +-- does not exist then the process won the race and it can proceed. +-- +-- * Register the package into the package db. Note that the files are not in +-- their final location at this stage so registration file checks may need +-- to be disabled. +-- +-- * Atomically rename the temp dir to the final store entry location. +-- +-- * Release the previously-acquired lock. +-- +-- Obviously this means it is possible to fail after registering but before +-- installing the store entry, leaving a dangling package db entry. This is not +-- much of a problem because this entry does not determine package existence +-- for cabal. It does mean however that the package db update should be insert +-- or replace, i.e. not failing if the db entry already exists. + + +-- | Check if a particular 'UnitId' exists in the store. +-- +doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = + doesDirectoryExist (storePackageDirectory compid unitid) + + +-- | Return the 'UnitId's of all packages\/components already installed in the +-- store. +-- +getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} compid = do + paths <- getDirectoryContentsMonitored (storeDirectory compid) + return $! mkEntries paths + where + mkEntries = Set.delete (mkUnitId "package.db") + . Set.delete (mkUnitId "incoming") + . Set.fromList + . map mkUnitId + . filter valid + valid ('.':_) = False + valid _ = True + + +-- | The outcome of 'newStoreEntry': either the store entry was newly created +-- or it existed already. The latter case happens if there was a race between +-- two builds of the same store entry. +-- +data NewStoreEntryOutcome = UseNewStoreEntry + | UseExistingStoreEntry + deriving (Eq, Show) + +-- | Place a new entry into the store. See the concurrency strategy description +-- for full details. +-- +-- In particular, it takes two actions: one to place files into a temporary +-- location, and a second to perform any necessary registration. The first +-- action is executed without any locks held (the temp dir is unique). The +-- second action holds a lock that guarantees that only one cabal process is +-- able to install this store entry. This means it is safe to register into +-- the compiler package DB or do other similar actions. +-- +-- Note that if you need to use the registration information later then you +-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' +-- then you must read the existing registration information (unless your +-- registration information is constructed fully deterministically). +-- +newStoreEntry :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO FilePath) -- ^ Action to place files. + -> IO () -- ^ Register action, if necessary. + -> IO NewStoreEntryOutcome +newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} + compid unitid + copyFiles register = + -- See $concurrency above for an explanation of the concurrency protocol + + withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do + + -- Write all store entry files within the temp dir and return the prefix. + incomingEntryDir <- copyFiles incomingTmpDir + + -- Take a lock named after the 'UnitId' in question. + withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do + + -- Check for the existence of the final store entry directory. + exists <- doesStoreEntryExist storeDirLayout compid unitid + + if exists + -- If the entry exists then we lost the race and we must abandon, + -- unlock and re-use the existing store entry. + then do + info verbosity $ + "Concurrent build race: abandoning build in favour of existing " + ++ "store entry " ++ display compid display unitid + return UseExistingStoreEntry + + -- If the entry does not exist then we won the race and can proceed. + else do + + -- Register the package into the package db (if appropriate). + register + + -- Atomically rename the temp dir to the final store entry location. + renameDirectory incomingEntryDir finalEntryDir + + debug verbosity $ + "Installed store entry " ++ display compid display unitid + return UseNewStoreEntry + where + finalEntryDir = storePackageDirectory compid unitid + + +withTempIncomingDir :: StoreDirLayout -> CompilerId + -> (FilePath -> IO a) -> IO a +withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do + createDirectoryIfMissing True incomingDir + withTempDirectory silent incomingDir "new" action + where + incomingDir = storeIncomingDirectory compid + + +withIncomingUnitIdLock :: Verbosity -> StoreDirLayout + -> CompilerId -> UnitId + -> IO a -> IO a +withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} + compid unitid action = + bracket takeLock releaseLock (\_hnd -> action) + where + takeLock = do + h <- openFile (storeIncomingLock compid unitid) ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ display compid display unitid + hLock h ExclusiveLock + return h + + releaseLock = hClose + diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/TargetSelector.hs @@ -0,0 +1,2246 @@ +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.TargetSelector +-- Copyright : (c) Duncan Coutts 2012, 2015, 2016 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified target selectors. +-- +----------------------------------------------------------------------------- +module Distribution.Client.TargetSelector ( + + -- * Target selectors + TargetSelector(..), + TargetImplicitCwd(..), + ComponentKind(..), + SubComponentTarget(..), + QualLevel(..), + componentKind, + + -- * Reading target selectors + readTargetSelectors, + TargetSelectorProblem(..), + reportTargetSelectorProblems, + showTargetSelector, + TargetString, + showTargetString, + parseTargetString, + -- ** non-IO + readTargetSelectorsWith, + DirActions(..), + defaultDirActions, + ) where + +import Distribution.Package + ( Package(..), PackageId, PackageIdentifier(..), packageName + , mkPackageName ) +import Distribution.Version + ( mkVersion ) +import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) +import Distribution.Client.Types + ( PackageLocation(..) ) + +import Distribution.Verbosity +import Distribution.PackageDescription + ( PackageDescription + , Executable(..) + , TestSuite(..), TestSuiteInterface(..), testModules + , Benchmark(..), BenchmarkInterface(..), benchmarkModules + , BuildInfo(..), explicitLibModules, exeModules ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import Distribution.Simple.LocalBuildInfo + ( Component(..), ComponentName(..) + , pkgComponents, componentName, componentBuildInfo ) +import Distribution.Types.ForeignLib + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Simple.Utils + ( die', lowercase, ordNub ) +import Distribution.Client.Utils + ( makeRelativeCanonical ) + +import Data.Either + ( partitionEithers ) +import Data.Function + ( on ) +import Data.List + ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) +import Data.Maybe + ( maybeToList ) +import Data.Ord + ( comparing ) +import Distribution.Compat.Binary (Binary) +import GHC.Generics (Generic) +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +#else +import qualified Data.Map as Map.Lazy +import qualified Data.Map as Map +import Data.Map (Map) +#endif +import qualified Data.Set as Set +import Control.Arrow ((&&&)) +import Control.Monad +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..), (<$>)) +#endif +import Control.Applicative (Alternative(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP + ( (+++), (<++) ) +import Distribution.ParseUtils + ( readPToMaybe ) +import Data.Char + ( isSpace, isAlphaNum ) +import System.FilePath as FilePath + ( takeExtension, dropExtension + , splitDirectories, joinPath, splitPath ) +import qualified System.Directory as IO + ( doesFileExist, doesDirectoryExist, canonicalizePath + , getCurrentDirectory ) +import System.FilePath + ( (), (<.>), normalise, dropTrailingPathSeparator ) +import Text.EditDistance + ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) + + +-- ------------------------------------------------------------ +-- * Target selector terms +-- ------------------------------------------------------------ + +-- | A target selector is expression selecting a set of components (as targets +-- for a actions like @build@, @run@, @test@ etc). A target selector +-- corresponds to the user syntax for referring to targets on the command line. +-- +-- From the users point of view a target can be many things: packages, dirs, +-- component names, files etc. Internally we consider a target to be a specific +-- component (or module\/file within a component), and all the users' notions +-- of targets are just different ways of referring to these component targets. +-- +-- So target selectors are expressions in the sense that they are interpreted +-- to refer to one or more components. For example a 'TargetPackage' gets +-- interpreted differently by different commands to refer to all or a subset +-- of components within the package. +-- +-- The syntax has lots of optional parts: +-- +-- > [ package name | package dir | package .cabal file ] +-- > [ [lib:|exe:] component name ] +-- > [ module name | source file ] +-- +data TargetSelector pkg = + + -- | A package as a whole: the default components for the package or all + -- components of a particular kind. + -- + TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter) + + -- | All packages, or all components of a particular kind in all packages. + -- + | TargetAllPackages (Maybe ComponentKindFilter) + + -- | A specific component in a package. + -- + | TargetComponent pkg ComponentName SubComponentTarget + deriving (Eq, Ord, Functor, Show, Generic) + +-- | Does this 'TargetPackage' selector arise from syntax referring to a +-- packge in the current directory (e.g. @tests@ or no giving no explicit +-- target at all) or does it come from syntax referring to a package name +-- or location. +-- +data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed + deriving (Eq, Ord, Show, Generic) + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Enum, Show) + +type ComponentKindFilter = ComponentKind + +-- | Either the component as a whole or detail about a file or module target +-- within a component. +-- +data SubComponentTarget = + + -- | The component as a whole + WholeComponent + + -- | A specific module within a component. + | ModuleTarget ModuleName + + -- | A specific file within a component. + | FileTarget FilePath + deriving (Eq, Ord, Show, Generic) + +instance Binary SubComponentTarget + + +-- ------------------------------------------------------------ +-- * Top level, do everything +-- ------------------------------------------------------------ + + +-- | Parse a bunch of command line args as 'TargetSelector's, failing with an +-- error if any are unrecognised. The possible target selectors are based on +-- the available packages (and their locations). +-- +readTargetSelectors :: [SourcePackage (PackageLocation a)] + -> [String] + -> IO (Either [TargetSelectorProblem] + [TargetSelector PackageId]) +readTargetSelectors = readTargetSelectorsWith defaultDirActions + +readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m + -> [SourcePackage (PackageLocation a)] + -> [String] + -> m (Either [TargetSelectorProblem] + [TargetSelector PackageId]) +readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = + case parseTargetStrings targetStrs of + ([], utargets) -> do + utargets' <- mapM (getTargetStringFileStatus dirActions) utargets + pkgs' <- mapM (selectPackageInfo dirActions) pkgs + cwd <- getCurrentDirectory + let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs' + case resolveTargetSelectors cwdPkg otherPkgs utargets' of + ([], btargets) -> return (Right (map (fmap packageId) btargets)) + (problems, _) -> return (Left problems) + (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + where + selectCwdPackage :: FilePath + -> [PackageInfo] + -> ([PackageInfo], [PackageInfo]) + selectCwdPackage cwd pkgs' = + let (cwdpkg, others) = partition isPkgDirCwd pkgs' + in (cwdpkg, others) + where + isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } + | dir == cwd = True + isPkgDirCwd _ = False + +data DirActions m = DirActions { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + canonicalizePath :: FilePath -> m FilePath, + getCurrentDirectory :: m FilePath + } + +defaultDirActions :: DirActions IO +defaultDirActions = + DirActions { + doesFileExist = IO.doesFileExist, + doesDirectoryExist = IO.doesDirectoryExist, + -- Workaround for + canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, + getCurrentDirectory = IO.getCurrentDirectory + } + +makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath +makeRelativeToCwd DirActions{..} path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + + +-- ------------------------------------------------------------ +-- * Parsing target strings +-- ------------------------------------------------------------ + +-- | The outline parse of a target selector. It takes one of the forms: +-- +-- > str1 +-- > str1:str2 +-- > str1:str2:str3 +-- > str1:str2:str3:str4 +-- +data TargetString = + TargetString1 String + | TargetString2 String String + | TargetString3 String String String + | TargetString4 String String String String + | TargetString5 String String String String String + | TargetString7 String String String String String String String + deriving (Show, Eq) + +-- | Parse a bunch of 'TargetString's (purely without throwing exceptions). +-- +parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings = + partitionEithers + . map (\str -> maybe (Left str) Right (parseTargetString str)) + +parseTargetString :: String -> Maybe TargetString +parseTargetString = + readPToMaybe parseTargetApprox + where + parseTargetApprox :: Parse.ReadP r TargetString + parseTargetApprox = + (do a <- tokenQ + return (TargetString1 a)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + return (TargetString2 a b)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + _ <- Parse.char ':' + c <- tokenQ + return (TargetString3 a b c)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + return (TargetString4 a b c d)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + return (TargetString5 a b c d e)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + _ <- Parse.char ':' + f <- tokenQ + _ <- Parse.char ':' + g <- tokenQ + return (TargetString7 a b c d e f g)) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + tokenQ = parseHaskellString <++ token + token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') + tokenQ0= parseHaskellString <++ token0 + parseHaskellString :: Parse.ReadP r String + parseHaskellString = Parse.readS_to_P reads + + +-- | Render a 'TargetString' back as the external syntax. This is mainly for +-- error messages. +-- +showTargetString :: TargetString -> String +showTargetString = intercalate ":" . components + where + components (TargetString1 s1) = [s1] + components (TargetString2 s1 s2) = [s1,s2] + components (TargetString3 s1 s2 s3) = [s1,s2,s3] + components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] + components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] + components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] + +showTargetSelector :: Package p => TargetSelector p -> String +showTargetSelector ts = + let (t':_) = [ t | ql <- [QL1 .. QLFull] + , t <- renderTargetSelector ql ts ] + in showTargetString (forgetFileStatus t') + +showTargetSelectorKind :: TargetSelector a -> String +showTargetSelectorKind bt = case bt of + TargetPackage TargetExplicitNamed _ Nothing -> "package" + TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" + TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" + TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetAllPackages Nothing -> "all-packages" + TargetAllPackages (Just _) -> "all-packages:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + + +-- ------------------------------------------------------------ +-- * Checking if targets exist as files +-- ------------------------------------------------------------ + +data TargetStringFileStatus = + TargetStringFileStatus1 String FileStatus + | TargetStringFileStatus2 String FileStatus String + | TargetStringFileStatus3 String FileStatus String String + | TargetStringFileStatus4 String String String String + | TargetStringFileStatus5 String String String String String + | TargetStringFileStatus7 String String String String String String String + deriving (Eq, Ord, Show) + +data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath + | FileStatusExistsDir FilePath -- the canonicalised filepath + | FileStatusNotExists Bool -- does the parent dir exist even? + deriving (Eq, Ord, Show) + +noFileStatus :: FileStatus +noFileStatus = FileStatusNotExists False + +getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m + -> TargetString -> m TargetStringFileStatus +getTargetStringFileStatus DirActions{..} t = + case t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + where + fileStatus f = do + fexists <- doesFileExist f + dexists <- doesDirectoryExist f + case splitPath f of + _ | fexists -> FileStatusExistsFile <$> canonicalizePath f + | dexists -> FileStatusExistsDir <$> canonicalizePath f + (d:_) -> FileStatusNotExists <$> doesDirectoryExist d + _ -> pure (FileStatusNotExists False) + +forgetFileStatus :: TargetStringFileStatus -> TargetString +forgetFileStatus t = case t of + TargetStringFileStatus1 s1 _ -> TargetString1 s1 + TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 + TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 + TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 + TargetStringFileStatus5 s1 s2 s3 s4 + s5 -> TargetString5 s1 s2 s3 s4 s5 + TargetStringFileStatus7 s1 s2 s3 s4 + s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 + + +-- ------------------------------------------------------------ +-- * Resolving target strings to target selectors +-- ------------------------------------------------------------ + + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveTargetSelectors :: [PackageInfo] -- any pkg in the cur dir + -> [PackageInfo] -- all the other local packages + -> [TargetStringFileStatus] + -> ([TargetSelectorProblem], + [TargetSelector PackageInfo]) + +-- default local dir target if there's no given target: +resolveTargetSelectors [] [] [] = + ([TargetSelectorNoTargetsInProject], []) + +resolveTargetSelectors [] _opinfo [] = + ([TargetSelectorNoTargetsInCwd], []) + +resolveTargetSelectors ppinfo _opinfo [] = + ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing]) + --TODO: in future allow multiple packages in the same dir + +resolveTargetSelectors ppinfo opinfo targetStrs = + partitionEithers + . map (resolveTargetSelector ppinfo opinfo) + $ targetStrs + +resolveTargetSelector :: [PackageInfo] -> [PackageInfo] + -> TargetStringFileStatus + -> Either TargetSelectorProblem + (TargetSelector PackageInfo) +resolveTargetSelector ppinfo opinfo targetStrStatus = + case findMatch (matcher targetStrStatus) of + + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + + Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) + | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr) + | otherwise -> Right (TargetPackage TargetImplicitCwd + (head ppinfo) mkfilter) + --TODO: in future allow multiple packages in the same dir + + Unambiguous target -> Right target + + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher targetStrStatus exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr + (map (fmap (fmap packageId)) targets')) + Left ((m, ms):_) -> Left (MatchingInternalError targetStr + (fmap packageId m) + (map (fmap (map (fmap packageId))) ms)) + Left [] -> internalError "resolveTargetSelector" + where + matcher = matchTargetSelector ppinfo opinfo + + targetStr = forgetFileStatus targetStrStatus + + projectIsEmpty = null ppinfo && null opinfo + + classifyMatchErrors errs + | not (null expected) + = let (things, got:_) = unzip expected in + TargetSelectorExpected targetStr things got + + | not (null nosuch) + = TargetSelectorNoSuch targetStr nosuch + + | otherwise + = internalError $ "classifyMatchErrors: " ++ show errs + where + expected = [ (thing, got) + | (_, MatchErrorExpected thing got) + <- map (innerErr Nothing) errs ] + -- Trim the list of alternatives by dropping duplicates and + -- retaining only at most three most similar (by edit distance) ones. + nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ + [ ((inside, thing, got), Set.fromList alts) + | (inside, MatchErrorNoSuch thing got alts) + <- map (innerErr Nothing) errs + ] + + genResults (inside, thing, got) alts acc = ( + inside + , thing + , got + , take maxResults + $ map fst + $ takeWhile distanceLow + $ sortBy (comparing snd) + $ map addLevDist + $ Set.toList alts + ) : acc + where + addLevDist = id &&& restrictedDamerauLevenshteinDistance + defaultEditCosts got + + distanceLow (_, dist) = dist < length got `div` 2 + + maxResults = 3 + + innerErr _ (MatchErrorIn kind thing m) + = innerErr (Just (kind,thing)) m + innerErr c m = (c,m) + +-- | The various ways that trying to resolve a 'TargetString' to a +-- 'TargetSelector' can fail. +-- +data TargetSelectorProblem + = TargetSelectorExpected TargetString [String] String + -- ^ [expected thing] (actually got) + | TargetSelectorNoSuch TargetString + [(Maybe (String, String), String, String, [String])] + -- ^ [([in thing], no such thing, actually got, alternatives)] + | TargetSelectorAmbiguous TargetString + [(TargetString, TargetSelector PackageId)] + + | MatchingInternalError TargetString (TargetSelector PackageId) + [(TargetString, [TargetSelector PackageId])] + | TargetSelectorUnrecognised String + -- ^ Syntax error when trying to parse a target string. + | TargetSelectorNoCurrentPackage TargetString + | TargetSelectorNoTargetsInCwd + | TargetSelectorNoTargetsInProject + deriving (Show, Eq) + +data QualLevel = QL1 | QL2 | QL3 | QLFull + deriving (Eq, Enum, Show) + +disambiguateTargetSelectors + :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo)) + -> TargetStringFileStatus -> Bool + -> [TargetSelector PackageInfo] + -> Either [(TargetSelector PackageInfo, + [(TargetString, [TargetSelector PackageInfo])])] + [(TargetString, TargetSelector PackageInfo)] +disambiguateTargetSelectors matcher matchInput exactMatch matchResults = + case partitionEithers results of + (errs@(_:_), _) -> Left errs + ([], ok) -> Right ok + where + -- So, here's the strategy. We take the original match results, and make a + -- table of all their renderings at all qualification levels. + -- Note there can be multiple renderings at each qualification level. + matchResultsRenderings :: [(TargetSelector PackageInfo, + [TargetStringFileStatus])] + matchResultsRenderings = + [ (matchResult, matchRenderings) + | matchResult <- matchResults + , let matchRenderings = + [ rendering + | ql <- [QL1 .. QLFull] + , rendering <- renderTargetSelector ql matchResult ] + ] + + -- Of course the point is that we're looking for renderings that are + -- unambiguous matches. So we build another memo table of all the matches + -- for all of those renderings. So by looking up in this table we can see + -- if we've got an unambiguous match. + + memoisedMatches :: Map TargetStringFileStatus + (Match (TargetSelector PackageInfo)) + memoisedMatches = + -- avoid recomputing the main one if it was an exact match + (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) + else id) + $ Map.Lazy.fromList + [ (rendering, matcher rendering) + | rendering <- concatMap snd matchResultsRenderings ] + + -- Finally, for each of the match results, we go through all their + -- possible renderings (in order of qualification level, though remember + -- there can be multiple renderings per level), and find the first one + -- that has an unambiguous match. + results :: [Either (TargetSelector PackageInfo, + [(TargetString, [TargetSelector PackageInfo])]) + (TargetString, TargetSelector PackageInfo)] + results = + [ case findUnambiguous originalMatch matchRenderings of + Just unambiguousRendering -> + Right ( forgetFileStatus unambiguousRendering + , originalMatch) + + -- This case is an internal error, but we bubble it up and report it + Nothing -> + Left ( originalMatch + , [ (forgetFileStatus rendering, matches) + | rendering <- matchRenderings + , let (ExactMatch _ matches) = + memoisedMatches Map.! rendering + ] ) + + | (originalMatch, matchRenderings) <- matchResultsRenderings ] + + findUnambiguous :: TargetSelector PackageInfo + -> [TargetStringFileStatus] + -> Maybe TargetStringFileStatus + findUnambiguous _ [] = Nothing + findUnambiguous t (r:rs) = + case memoisedMatches Map.! r of + ExactMatch _ [t'] | fmap packageName t == fmap packageName t' + -> Just r + ExactMatch _ _ -> findUnambiguous t rs + InexactMatch _ _ -> internalError "InexactMatch" + NoMatch _ _ -> internalError "NoMatch" + +internalError :: String -> a +internalError msg = + error $ "TargetSelector: internal error: " ++ msg + + +-- | Throw an exception with a formatted message if there are any problems. +-- +reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a +reportTargetSelectorProblems verbosity problems = do + + case [ str | TargetSelectorUnrecognised str <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target syntax for '" ++ name ++ "'." + | name <- targets ] + + case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of + [] -> return () + ((target, originalMatch, renderingsAndMatches):_) -> + die' verbosity $ "Internal error in target matching. It should always " + ++ "be possible to find a syntax that's sufficiently qualified to " + ++ "give an unambiguous match. However when matching '" + ++ showTargetString target ++ "' we found " + ++ showTargetSelector originalMatch + ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " + ++ "not have an unambiguous syntax. The possible syntax and the " + ++ "targets they match are as follows:\n" + ++ unlines + [ "'" ++ showTargetString rendering ++ "' which matches " + ++ intercalate ", " + [ showTargetSelector match ++ + " (" ++ showTargetSelectorKind match ++ ")" + | match <- matches ] + | (rendering, matches) <- renderingsAndMatches ] + + case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target '" ++ showTargetString target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unknown target '" ++ showTargetString target ++ + "'.\n" ++ unlines + [ (case inside of + Just (kind, "") + -> "The " ++ kind ++ " has no " + Just (kind, thing) + -> "The " ++ kind ++ " " ++ thing ++ " has no " + Nothing -> "There is no ") + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got, _alts) <- nosuch' ] ++ "." + ++ if null alternatives then "" else + "\nPerhaps you meant " ++ intercalate ";\nor " + [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" + | (thing, alts) <- alternatives ] + | (inside, nosuch') <- groupByContainer nosuch + , let alternatives = + [ (thing, alts) + | (thing,_got,alts@(_:_)) <- nosuch' ] + ] + | (target, nosuch) <- targets + , let groupByContainer = + map (\g@((inside,_,_,_):_) -> + (inside, [ (thing,got,alts) + | (_,thing,got,alts) <- g ])) + . groupBy ((==) `on` (\(x,_,_,_) -> x)) + . sortBy (compare `on` (\(x,_,_,_) -> x)) + ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Ambiguous target '" ++ showTargetString target + ++ "'. It could be:\n " + ++ unlines [ " "++ showTargetString ut ++ + " (" ++ showTargetSelectorKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + case [ t | TargetSelectorNoCurrentPackage t <- problems ] of + [] -> return () + target:_ -> + die' verbosity $ + "The target '" ++ showTargetString target ++ "' refers to the " + ++ "components in the package in the current directory, but there " + ++ "is no package in the current directory (or at least not listed " + ++ "as part of the project)." + --TODO: report a different error if there is a .cabal file but it's + -- not a member of the project + + case [ () | TargetSelectorNoTargetsInCwd <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Use the target 'all' for all packages in the " + ++ "project or specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [ () | TargetSelectorNoTargetsInProject <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "There is no .cabal package file or cabal.project file. " + ++ "To build packages locally you need at minimum a .cabal " + ++ "file. You can use 'cabal init' to create one.\n" + ++ "\n" + ++ "For non-trivial projects you will also want a cabal.project " + ++ "file in the root directory of your project. This file lists the " + ++ "packages in your project and all other build configuration. " + ++ "See the Cabal user guide for full details." + + fail "reportTargetSelectorProblems: internal error" + + +---------------------------------- +-- Syntax type +-- + +-- | Syntax for the 'TargetSelector': the matcher and renderer +-- +data Syntax = Syntax QualLevel Matcher Renderer + | AmbiguousAlternatives Syntax Syntax + | ShadowingAlternatives Syntax Syntax + +type Matcher = TargetStringFileStatus -> Match (TargetSelector PackageInfo) +type Renderer = TargetSelector PackageId -> [TargetStringFileStatus] + +foldSyntax :: (a -> a -> a) -> (a -> a -> a) + -> (QualLevel -> Matcher -> Renderer -> a) + -> (Syntax -> a) +foldSyntax ambiguous unambiguous syntax = go + where + go (Syntax ql match render) = syntax ql match render + go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) + go (ShadowingAlternatives a b) = unambiguous (go a) (go b) + + +---------------------------------- +-- Top level renderer and matcher +-- + +renderTargetSelector :: Package p => QualLevel -> TargetSelector p + -> [TargetStringFileStatus] +renderTargetSelector ql ts = + foldSyntax + (++) (++) + (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts)) + syntax + where + syntax = syntaxForms [] [] -- don't need pinfo for rendering + +matchTargetSelector :: [PackageInfo] -> [PackageInfo] + -> TargetStringFileStatus + -> Match (TargetSelector PackageInfo) +matchTargetSelector ppinfo opinfo = \utarget -> + nubMatchesBy ((==) `on` (fmap packageName)) $ + + let ql = targetQualLevel utarget in + foldSyntax + (<|>) () + (\ql' match _ -> guard (ql == ql') >> match utarget) + syntax + where + syntax = syntaxForms ppinfo opinfo + + targetQualLevel TargetStringFileStatus1{} = QL1 + targetQualLevel TargetStringFileStatus2{} = QL2 + targetQualLevel TargetStringFileStatus3{} = QL3 + targetQualLevel TargetStringFileStatus4{} = QLFull + targetQualLevel TargetStringFileStatus5{} = QLFull + targetQualLevel TargetStringFileStatus7{} = QLFull + + +---------------------------------- +-- Syntax forms +-- + +-- | All the forms of syntax for 'TargetSelector'. +-- +syntaxForms :: [PackageInfo] -> [PackageInfo] -> Syntax +syntaxForms ppinfo opinfo = + -- The various forms of syntax here are ambiguous in many cases. + -- Our policy is by default we expose that ambiguity and report + -- ambiguous matches. In certain cases we override the ambiguity + -- by having some forms shadow others. + -- + -- We make modules shadow files because module name "Q" clashes + -- with file "Q" with no extension but these refer to the same + -- thing anyway so it's not a useful ambiguity. Other cases are + -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". + + ambiguousAlternatives + -- convenient single-component forms + [ shadowingAlternatives + [ ambiguousAlternatives + [ syntaxForm1All + , syntaxForm1Filter + , shadowingAlternatives + [ syntaxForm1Component pcinfo + , syntaxForm1Package pinfo + ] + ] + , syntaxForm1Component ocinfo + , syntaxForm1Module cinfo + , syntaxForm1File pinfo + ] + + -- two-component partially qualified forms + -- fully qualified form for 'all' + , syntaxForm2MetaAll + , syntaxForm2AllFilter + , syntaxForm2NamespacePackage pinfo + , syntaxForm2PackageComponent pinfo + , syntaxForm2PackageFilter pinfo + , syntaxForm2KindComponent cinfo + , shadowingAlternatives + [ syntaxForm2PackageModule pinfo + , syntaxForm2PackageFile pinfo + ] + , shadowingAlternatives + [ syntaxForm2ComponentModule cinfo + , syntaxForm2ComponentFile cinfo + ] + + -- rarely used partially qualified forms + , syntaxForm3PackageKindComponent pinfo + , shadowingAlternatives + [ syntaxForm3PackageComponentModule pinfo + , syntaxForm3PackageComponentFile pinfo + ] + , shadowingAlternatives + [ syntaxForm3KindComponentModule cinfo + , syntaxForm3KindComponentFile cinfo + ] + , syntaxForm3NamespacePackageFilter pinfo + + -- fully-qualified forms for all and cwd with filter + , syntaxForm3MetaAllFilter + , syntaxForm3MetaCwdFilter + + -- fully-qualified form for package and package with filter + , syntaxForm3MetaNamespacePackage pinfo + , syntaxForm4MetaNamespacePackageFilter pinfo + + -- fully-qualified forms for component, module and file + , syntaxForm5MetaNamespacePackageKindComponent pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo + ] + where + ambiguousAlternatives = foldr1 AmbiguousAlternatives + shadowingAlternatives = foldr1 ShadowingAlternatives + pinfo = ppinfo ++ opinfo + cinfo = concatMap pinfoComponents pinfo + pcinfo = concatMap pinfoComponents ppinfo + ocinfo = concatMap pinfoComponents opinfo + + +-- | Syntax: "all" to select all packages in the project +-- +-- > cabal build all +-- +syntaxForm1All :: Syntax +syntaxForm1All = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardMetaAll str1 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus1 "all" noFileStatus] + render _ = [] + +-- | Syntax: filter +-- +-- > cabal build tests +-- +syntaxForm1Filter :: Syntax +syntaxForm1Filter = + syntaxForm1 render $ \str1 _fstatus1 -> do + kfilter <- matchComponentKindFilter str1 + return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + where + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus1 (dispF kfilter) noFileStatus] + render _ = [] + +-- Only used for TargetPackage TargetImplicitCwd +dummyPackageInfo :: PackageInfo +dummyPackageInfo = + PackageInfo { + pinfoId = PackageIdentifier + (mkPackageName "dummyPackageInfo") + (mkVersion []), + pinfoLocation = unused, + pinfoDirectory = unused, + pinfoPackageFile = unused, + pinfoComponents = unused + } + where + unused = error "dummyPackageInfo" + +-- | Syntax: package (name, dir or file) +-- +-- > cabal build foo +-- > cabal build ../bar ../bar/bar.cabal +-- +syntaxForm1Package :: [PackageInfo] -> Syntax +syntaxForm1Package pinfo = + syntaxForm1 render $ \str1 fstatus1 -> do + guardPackage str1 fstatus1 + p <- matchPackage pinfo str1 fstatus1 + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus1 (dispP p) noFileStatus] + render _ = [] + +-- | Syntax: component +-- +-- > cabal build foo +-- +syntaxForm1Component :: [ComponentInfo] -> Syntax +syntaxForm1Component cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus1 (dispC p c) noFileStatus] + render _ = [] + +-- | Syntax: module +-- +-- > cabal build Data.Foo +-- +syntaxForm1Module :: [ComponentInfo] -> Syntax +syntaxForm1Module cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardModuleName str1 + let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str1 + return (TargetComponent (cinfoPackage c) (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent _p _c (ModuleTarget m)) = + [TargetStringFileStatus1 (dispM m) noFileStatus] + render _ = [] + +-- | Syntax: file name +-- +-- > cabal build Data/Foo.hs bar/Main.hsc +-- +syntaxForm1File :: [PackageInfo] -> Syntax +syntaxForm1File ps = + -- Note there's a bit of an inconsistency here vs the other syntax forms + -- for files. For the single-part syntax the target has to point to a file + -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for + -- all the other forms we don't require that. + syntaxForm1 render $ \str1 fstatus1 -> + expecting "file" str1 $ do + (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent _p _c (FileTarget f)) = + [TargetStringFileStatus1 f noFileStatus] + render _ = [] + +--- + +-- | Syntax: :all +-- +-- > cabal build :all +-- +syntaxForm2MetaAll :: Syntax +syntaxForm2MetaAll = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus2 "" noFileStatus "all"] + render _ = [] + +-- | Syntax: all : filer +-- +-- > cabal build all:tests +-- +syntaxForm2AllFilter :: Syntax +syntaxForm2AllFilter = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardMetaAll str1 + kfilter <- matchComponentKindFilter str2 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: package : filer +-- +-- > cabal build foo:tests +-- +syntaxForm2PackageFilter :: [PackageInfo] -> Syntax +syntaxForm2PackageFilter ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + kfilter <- matchComponentKindFilter str2 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: pkg : package name +-- +-- > cabal build pkg:foo +-- +syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax +syntaxForm2NamespacePackage pinfo = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage pinfo str2 noFileStatus + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render _ = [] + +-- | Syntax: package : component +-- +-- > cabal build foo:foo +-- > cabal build ./foo:foo +-- > cabal build ./foo.cabal:foo +-- +syntaxForm2PackageComponent :: [PackageInfo] -> Syntax +syntaxForm2PackageComponent ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + return (TargetComponent p (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: namespace : component +-- +-- > cabal build lib:foo exe:foo +-- +syntaxForm2KindComponent :: [ComponentInfo] -> Syntax +syntaxForm2KindComponent cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: package : module +-- +-- > cabal build foo:Data.Foo +-- > cabal build ./foo:Data.Foo +-- > cabal build ./foo.cabal:Data.Foo +-- +syntaxForm2PackageModule :: [PackageInfo] -> Syntax +syntaxForm2PackageModule ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardModuleName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p _c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: component : module +-- +-- > cabal build foo:Data.Foo +-- +syntaxForm2ComponentModule :: [ComponentInfo] -> Syntax +syntaxForm2ComponentModule cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: package : filename +-- +-- > cabal build foo:Data/Foo.hs +-- > cabal build ./foo:Data/Foo.hs +-- > cabal build ./foo.cabal:Data/Foo.hs +-- +syntaxForm2PackageFile :: [PackageInfo] -> Syntax +syntaxForm2PackageFile ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + (filepath, c) <- matchComponentFile (pinfoComponents p) str2 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p _c (FileTarget f)) = + [TargetStringFileStatus2 (dispP p) noFileStatus f] + render _ = [] + +-- | Syntax: component : filename +-- +-- > cabal build foo:Data/Foo.hs +-- +syntaxForm2ComponentFile :: [ComponentInfo] -> Syntax +syntaxForm2ComponentFile cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus f] + render _ = [] + +--- + +-- | Syntax: :all : filter +-- +-- > cabal build :all:tests +-- +syntaxForm3MetaAllFilter :: Syntax +syntaxForm3MetaAllFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + kfilter <- matchComponentKindFilter str3 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] + render _ = [] + +syntaxForm3MetaCwdFilter :: Syntax +syntaxForm3MetaCwdFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespaceCwd str2 + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + where + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package name +-- +-- > cabal build :pkg:foo +-- +syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax +syntaxForm3MetaNamespacePackage pinfo = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage pinfo str3 noFileStatus + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render _ = [] + +-- | Syntax: package : namespace : component +-- +-- > cabal build foo:lib:foo +-- > cabal build foo/:lib:foo +-- > cabal build foo.cabal:lib:foo +-- +syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm3PackageKindComponent ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + ckind <- matchComponentKind str2 + guardComponentName str3 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str3 + return (TargetComponent p (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] + render _ = [] + +-- | Syntax: package : component : module +-- +-- > cabal build foo:foo:Data.Foo +-- > cabal build foo/:foo:Data.Foo +-- > cabal build foo.cabal:foo:Data.Foo +-- +syntaxForm3PackageComponentModule :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentModule ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + guardModuleName str3 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: namespace : component : module +-- +-- > cabal build lib:foo:Data.Foo +-- +syntaxForm3KindComponentModule :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentModule cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + guardModuleName str3 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: package : component : filename +-- +-- > cabal build foo:foo:Data/Foo.hs +-- > cabal build foo/:foo:Data/Foo.hs +-- > cabal build foo.cabal:foo:Data/Foo.hs +-- +syntaxForm3PackageComponentFile :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentFile ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render _ = [] + +-- | Syntax: namespace : component : filename +-- +-- > cabal build lib:foo:Data/Foo.hs +-- +syntaxForm3KindComponentFile :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentFile cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f] + render _ = [] + +syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm3NamespacePackageFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage ps str2 noFileStatus + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render _ = [] + +-- + +syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm4MetaNamespacePackageFilter ps = + syntaxForm4 render $ \str1 str2 str3 str4 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage ps str3 noFileStatus + kfilter <- matchComponentKindFilter str4 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component +-- +-- > cabal build :pkg:foo:lib:foo +-- +syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent ps = + syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + return (TargetComponent p (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : module : module +-- +-- > cabal build :pkg:foo:lib:foo:module:Data.Foo +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule + :: [PackageInfo] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceModule str6 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispK c) (dispC p c) + "module" (dispM m)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : file : filename +-- +-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile + :: [PackageInfo] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceFile str6 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispK c) (dispC p c) + "file" f] + render _ = [] + + +--------------------------------------- +-- Syntax utils +-- + +type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo) +type Match2 = String -> FileStatus -> String + -> Match (TargetSelector PackageInfo) +type Match3 = String -> FileStatus -> String -> String + -> Match (TargetSelector PackageInfo) +type Match4 = String -> String -> String -> String + -> Match (TargetSelector PackageInfo) +type Match5 = String -> String -> String -> String -> String + -> Match (TargetSelector PackageInfo) +type Match7 = String -> String -> String -> String -> String -> String -> String + -> Match (TargetSelector PackageInfo) + +syntaxForm1 :: Renderer -> Match1 -> Syntax +syntaxForm2 :: Renderer -> Match2 -> Syntax +syntaxForm3 :: Renderer -> Match3 -> Syntax +syntaxForm4 :: Renderer -> Match4 -> Syntax +syntaxForm5 :: Renderer -> Match5 -> Syntax +syntaxForm7 :: Renderer -> Match7 -> Syntax + +syntaxForm1 render f = + Syntax QL1 match render + where + match = \(TargetStringFileStatus1 str1 fstatus1) -> + f str1 fstatus1 + +syntaxForm2 render f = + Syntax QL2 match render + where + match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> + f str1 fstatus1 str2 + +syntaxForm3 render f = + Syntax QL3 match render + where + match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> + f str1 fstatus1 str2 str3 + +syntaxForm4 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus4 str1 str2 str3 str4) + = f str1 str2 str3 str4 + match _ = mzero + +syntaxForm5 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus5 str1 str2 str3 str4 str5) + = f str1 str2 str3 str4 str5 + match _ = mzero + +syntaxForm7 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) + = f str1 str2 str3 str4 str5 str6 str7 + match _ = mzero + +dispP :: Package p => p -> String +dispP = display . packageName + +dispC :: Package p => p -> ComponentName -> String +dispC = componentStringName + +dispK :: ComponentName -> String +dispK = showComponentKindShort . componentKind + +dispF :: ComponentKind -> String +dispF = showComponentKindFilterShort + +dispM :: ModuleName -> String +dispM = display + + +------------------------------- +-- Package and component info +-- + +data PackageInfo = PackageInfo { + pinfoId :: PackageId, + pinfoLocation :: PackageLocation (), + pinfoDirectory :: Maybe (FilePath, FilePath), + pinfoPackageFile :: Maybe (FilePath, FilePath), + pinfoComponents :: [ComponentInfo] + } + -- not instance of Show due to recursive construction + +data ComponentInfo = ComponentInfo { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackage :: PackageInfo, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] + } + -- not instance of Show due to recursive construction + +type ComponentStringName = String + +instance Package PackageInfo where + packageId = pinfoId + +selectPackageInfo :: (Applicative m, Monad m) => DirActions m + -> SourcePackage (PackageLocation a) -> m PackageInfo +selectPackageInfo dirActions@DirActions{..} + SourcePackage { + packageDescription = pkg, + packageSource = loc + } = do + (pkgdir, pkgfile) <- + case loc of + --TODO: local tarballs, remote tarballs etc + LocalUnpackedPackage dir -> do + dirabs <- canonicalizePath dir + dirrel <- makeRelativeToCwd dirActions dirabs + --TODO: ought to get this earlier in project reading + let fileabs = dirabs display (packageName pkg) <.> "cabal" + filerel = dirrel display (packageName pkg) <.> "cabal" + exists <- doesFileExist fileabs + return ( Just (dirabs, dirrel) + , if exists then Just (fileabs, filerel) else Nothing + ) + _ -> return (Nothing, Nothing) + let pinfo = + PackageInfo { + pinfoId = packageId pkg, + pinfoLocation = fmap (const ()) loc, + pinfoDirectory = pkgdir, + pinfoPackageFile = pkgfile, + pinfoComponents = selectComponentInfo pinfo + (flattenPackageDescription pkg) + } + return pinfo + + +selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] +selectComponentInfo pinfo pkg = + [ ComponentInfo { + cinfoName = componentName c, + cinfoStrName = componentStringName pkg (componentName c), + cinfoPackage = pinfo, + cinfoSrcDirs = ordNub (hsSourceDirs bi), +-- [ pkgroot srcdir +-- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) +-- , srcdir <- hsSourceDirs bi ], + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg CLibName = display (packageName pkg) +componentStringName _ (CSubLibName name) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- I think it's unlikely users will ask to build a requirement +-- which is not mentioned locally. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + + +------------------------------ +-- Matching meta targets +-- + +guardNamespaceMeta :: String -> Match () +guardNamespaceMeta = guardToken [""] "meta namespace" + +guardMetaAll :: String -> Match () +guardMetaAll = guardToken ["all"] "meta-target 'all'" + +guardNamespacePackage :: String -> Match () +guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" + +guardNamespaceCwd :: String -> Match () +guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" + +guardNamespaceModule :: String -> Match () +guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" + +guardNamespaceFile :: String -> Match () +guardNamespaceFile = guardToken ["file"] "'file' namespace" + +guardToken :: [String] -> String -> String -> Match () +guardToken tokens msg s + | caseFold s `elem` tokens = increaseConfidence + | otherwise = matchErrorExpected msg s + + +------------------------------ +-- Matching component kinds +-- + +componentKind :: ComponentName -> ComponentKind +componentKind CLibName = LibKind +componentKind (CSubLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind" s + where + s' = caseFold s + liblabels = ["lib", "library"] + fliblabels = ["flib", "foreign-library"] + exelabels = ["exe", "executable"] + testlabels = ["tst", "test", "test-suite"] + benchlabels = ["bench", "benchmark"] + +matchComponentKindFilter :: String -> Match ComponentKind +matchComponentKindFilter s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind filter" s + where + s' = caseFold s + liblabels = ["libs", "libraries"] + fliblabels = ["flibs", "foreign-libraries"] + exelabels = ["exes", "executables"] + testlabels = ["tests", "test-suites"] + benchlabels = ["benches", "benchmarks"] + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +showComponentKindFilterShort :: ComponentKind -> String +showComponentKindFilterShort LibKind = "libs" +showComponentKindFilterShort FLibKind = "flibs" +showComponentKindFilterShort ExeKind = "exes" +showComponentKindFilterShort TestKind = "tests" +showComponentKindFilterShort BenchKind = "benchmarks" + + +------------------------------ +-- Matching package targets +-- + +guardPackage :: String -> FileStatus -> Match () +guardPackage str fstatus = + guardPackageName str + <|> guardPackageDir str fstatus + <|> guardPackageFile str fstatus + + +guardPackageName :: String -> Match () +guardPackageName s + | validPackageName s = increaseConfidence + | otherwise = matchErrorExpected "package name" s + +validPackageName :: String -> Bool +validPackageName s = + all validPackageNameChar s + && not (null s) + where + validPackageNameChar c = isAlphaNum c || c == '-' + + +guardPackageDir :: String -> FileStatus -> Match () +guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence +guardPackageDir str _ = matchErrorExpected "package directory" str + + +guardPackageFile :: String -> FileStatus -> Match () +guardPackageFile _ (FileStatusExistsFile file) + | takeExtension file == ".cabal" + = increaseConfidence +guardPackageFile str _ = matchErrorExpected "package .cabal file" str + + +matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackage pinfo = \str fstatus -> + orNoThingIn "project" "" $ + matchPackageName pinfo str + (matchPackageDir pinfo str fstatus + <|> matchPackageFile pinfo str fstatus) + + +matchPackageName :: [PackageInfo] -> String -> Match PackageInfo +matchPackageName ps = \str -> do + guard (validPackageName str) + orNoSuchThing "package" str + (map (display . packageName) ps) $ + increaseConfidenceFor $ + matchInexactly caseFold (display . packageName) ps str + + +matchPackageDir :: [PackageInfo] + -> String -> FileStatus -> Match PackageInfo +matchPackageDir ps = \str fstatus -> + case fstatus of + FileStatusExistsDir canondir -> + orNoSuchThing "package directory" str (map (snd . fst) dirs) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) dirs canondir + _ -> mzero + where + dirs = [ ((dabs,drel),p) + | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] + + +matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackageFile ps = \str fstatus -> do + case fstatus of + FileStatusExistsFile canonfile -> + orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) files canonfile + _ -> mzero + where + files = [ ((fabs,frel),p) + | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + +--TODO: test outcome when dir exists but doesn't match any known one + +--TODO: perhaps need another distinction, vs no such thing, point is the +-- thing is not known, within the project, but could be outside project + + +------------------------------ +-- Matching component targets +-- + + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str (map cinfoStrName cs) + $ increaseConfidenceFor + $ matchInexactly caseFold cinfoStrName cs str + + +matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + (map render cs) + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + (\c -> (cinfoKind c, cinfoStrName c)) + cs + (ckind, str) + where + render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c + + +------------------------------ +-- Matching module targets +-- + +guardModuleName :: String -> Match () +guardModuleName s = + case simpleParse s :: Maybe ModuleName of + Just _ -> increaseConfidence + _ | all validModuleChar s + && not (null s) -> return () + | otherwise -> matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str (map display ms) + $ increaseConfidenceFor + $ matchInexactly caseFold display ms str + + +matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) +matchModuleNameAnd ms str = + orNoSuchThing "module" str (map (display . fst) ms) + $ increaseConfidenceFor + $ matchInexactly caseFold (display . fst) ms str + + +------------------------------ +-- Matching file targets +-- + +matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus + -> Match (FilePath, PackageInfo) +matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = + increaseConfidenceFor $ + matchDirectoryPrefix pkgdirs filepath + where + pkgdirs = [ (dir, p) + | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] +matchPackageDirectoryPrefix _ _ = mzero + + +matchComponentFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentFile cs str = + orNoSuchThing "file" str [] $ + matchComponentModuleFile cs str + <|> matchComponentOtherFile cs str + + +matchComponentOtherFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentOtherFile cs = + matchFile + [ (file, c) + | c <- cs + , file <- cinfoHsFiles c + ++ cinfoCFiles c + ++ cinfoJsFiles c + ] + + +matchComponentModuleFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentModuleFile cs str = do + matchFile + [ (normalise (d toFilePath m), c) + | c <- cs + , d <- cinfoSrcDirs c + , m <- cinfoModules c + ] + (dropExtension (normalise str)) + +-- utils + +matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold fst fs + +matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchDirectoryPrefix dirs filepath = + tryEach $ + [ (file, x) + | (dir,x) <- dirs + , file <- maybeToList (stripDirectory dir) ] + where + stripDirectory :: FilePath -> Maybe FilePath + stripDirectory dir = + joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit + + filepathsplit = splitDirectories filepath + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we +-- can run a matcher against an input using 'findMatch'. +-- +data Match a = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving Show + +type Confidence = Int + +data MatchError = MatchErrorExpected String String -- thing got + | MatchErrorNoSuch String String [String] -- thing got alts + | MatchErrorIn String String MatchError -- kind thing + deriving (Show, Eq) + + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Alternative Match where + empty = NoMatch 0 [] + (<|>) = matchPlus + +instance Monad Match where + return = pure + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = addDepth d + $ msum (map f xs) + InexactMatch d xs >>= f = addDepth d . forceInexact + $ msum (map f xs) + +instance MonadPlus Match where + mzero = empty + mplus = matchPlus + +() :: Match a -> Match a -> Match a +() = matchPlusShadowing + +infixl 3 + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +-- This operator is associative, has unit 'mzero' and is also commutative. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a +matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'matchPlus' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +-- +-- This operator is associative, has unit 'mzero' and is not commutative. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) _ = a +matchPlusShadowing a b = matchPlus a b + + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] + +matchErrorNoSuch :: String -> String -> [String] -> Match a +matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> [String] -> Match a -> Match a +orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts +orNoSuchThing _ _ _ m = m + +orNoThingIn :: String -> String -> Match a -> Match a +orNoThingIn kind name (NoMatch n ms) = + NoMatch n [ MatchErrorIn kind name m | m <- ms ] +orNoThingIn _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) +nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = mzero +exactMatches xs = ExactMatch 0 xs + +inexactMatches [] = mzero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Match a -> MaybeAmbiguous a +findMatch match = case match of + NoMatch _ msgs -> None msgs + ExactMatch _ [x] -> Unambiguous x + InexactMatch _ [x] -> Unambiguous x + ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" + InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" + ExactMatch _ xs -> Ambiguous True xs + InexactMatch _ xs -> Ambiguous False xs + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) +matchExactly key xs = + \k -> case Map.lookup k m of + Nothing -> mzero + Just ys -> exactMatches ys + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) + -> [a] -> (k -> Match a) +matchInexactly cannonicalise key xs = + \k -> case Map.lookup k m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise k) m' of + Just ys -> inexactMatches ys + Nothing -> mzero + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + + +------------------------------ +-- Example inputs +-- + +{- +ex1pinfo :: [PackageInfo] +ex1pinfo = + [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ + PackageInfo { + pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), + pinfoLocation = LocalUnpackedPackage "/the/foo", + pinfoDirectory = Just ("/the/foo", "foo"), + pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), + pinfoComponents = [] + } + , PackageInfo { + pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), + pinfoLocation = LocalUnpackedPackage "/the/foo", + pinfoDirectory = Just ("/the/bar", "bar"), + pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), + pinfoComponents = [] + } + ] + where + addComponent n ds ms p = + p { + pinfoComponents = + ComponentInfo n (componentStringName (pinfoId p) n) + p ds (map mkMn ms) + [] [] [] + : pinfoComponents p + } + + mkMn :: String -> ModuleName + mkMn = ModuleName.fromString +-} +{- +stargets = + [ TargetComponent (CExeName "foo") WholeComponent + , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) + , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Targets @@ -41,28 +43,36 @@ disambiguatePackageName, -- * User constraints + UserQualifier(..), + UserConstraintScope(..), UserConstraint(..), userConstraintPackageName, readUserConstraint, userToPackageConstraint, - dispFlagAssignment, - parseFlagAssignment, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package - ( Package(..), PackageName(..) - , PackageIdentifier(..), packageName, packageVersion - , Dependency(Dependency) ) + ( Package(..), PackageName, unPackageName, mkPackageName + , PackageIdentifier(..), packageName, packageVersion ) +import Distribution.Types.Dependency import Distribution.Client.Types - ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) -import Distribution.Client.Dependency.Types - ( PackageConstraint(..), ConstraintSource(..) - , LabeledPackageConstraint(..) ) + ( PackageLocation(..) + , ResolvedPkgLoc, UnresolvedSourcePackage ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.SourcePackage + import qualified Distribution.Client.World as World -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar @@ -72,51 +82,44 @@ ( RepoContext(..) ) import Distribution.PackageDescription - ( GenericPackageDescription, FlagName(..), FlagAssignment ) -import Distribution.PackageDescription.Parse - ( readPackageDescription, parsePackageDescription, ParseResult(..) ) + ( GenericPackageDescription, parseFlagAssignment ) import Distribution.Version - ( Version(Version), thisVersion, anyVersion, isAnyVersion - , VersionRange ) + ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM ) + ( die', warn, lowercase ) -import Data.List - ( find, nub ) -import Data.Maybe - ( listToMaybe ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) +#else +import Distribution.PackageDescription.Parse + ( readGenericPackageDescription, parseGenericPackageDescription, ParseResult(..) ) +import Distribution.Simple.Utils + ( fromUTF8, ignoreBOM ) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +#endif + +-- import Data.List ( find, nub ) import Data.Either ( partitionEithers ) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid - ( Monoid(..) ) -#endif import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Client.GZipUtils as GZipUtils -import Control.Monad (liftM) +import Control.Monad (mapM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) -import qualified Distribution.Compat.Semigroup as Semi - ( Semigroup((<>)) ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( (<>), (<+>) ) -import Data.Char - ( isSpace, isAlphaNum ) +import Distribution.ParseUtils + ( readPToMaybe ) import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory ( doesFileExist, doesDirectoryExist ) import Network.URI ( URI(..), URIAuth(..), parseAbsoluteURI ) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary) -- ------------------------------------------------------------ -- * User targets @@ -185,10 +188,10 @@ -- | A partially specified reference to a package (either source or -- installed). It is specified by package name and optionally some - -- additional constraints. Use a dependency resolver to pick a specific - -- package satisfying these constraints. + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. -- - NamedPackage PackageName [PackageConstraint] + NamedPackage PackageName [PackageProperty] -- | A fully specified source package. -- @@ -203,24 +206,27 @@ pkgSpecifierConstraints :: Package pkg => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props where - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget + toLpc prop = LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg) = [LabeledPackageConstraint pc ConstraintSourceUserTarget] where - pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) -- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] -readUserTargets _verbosity targetStrs = do +readUserTargets verbosity targetStrs = do (problems, targets) <- liftM partitionEithers (mapM readUserTarget targetStrs) - reportUserTargetProblems problems + reportUserTargetProblems verbosity problems return targets @@ -236,10 +242,12 @@ readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr = case testNamedTargets targetstr of - Just (Dependency (PackageName "world") verrange) - | verrange == anyVersion -> return (Right UserTargetWorld) - | otherwise -> return (Left UserTargetBadWorldPkg) - Just dep -> return (Right (UserTargetNamed dep)) + Just (Dependency pkgn verrange) + | pkgn == mkPackageName "world" + -> return $ if verrange == anyVersion + then Right UserTargetWorld + else Left UserTargetBadWorldPkg + Just dep -> return (Right (UserTargetNamed dep)) Nothing -> do fileTarget <- testFileTargets targetstr case fileTarget of @@ -302,19 +310,15 @@ where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of - Version [] _ -> Dependency (packageName p) anyVersion - version -> Dependency (packageName p) (thisVersion version) - -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] + v | v == nullVersion -> Dependency (packageName p) anyVersion + | otherwise -> Dependency (packageName p) (thisVersion v) -reportUserTargetProblems :: [UserTargetProblem] -> IO () -reportUserTargetProblems problems = do +reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () +reportUserTargetProblems verbosity problems = do case [ target | UserTargetUnrecognised target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised target '" ++ name ++ "'." | name <- target ] @@ -326,18 +330,18 @@ case [ () | UserTargetBadWorldPkg <- problems ] of [] -> return () - _ -> die "The special 'world' target does not take any version." + _ -> die' verbosity "The special 'world' target does not take any version." case [ target | UserTargetNonexistantFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "The file does not exist '" ++ name ++ "'." | name <- target ] case [ target | UserTargetUnexpectedFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised file target '" ++ name ++ "'." | name <- target ] @@ -346,7 +350,7 @@ case [ target | UserTargetUnexpectedUriScheme target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "URL target not supported '" ++ name ++ "'." | name <- target ] @@ -354,7 +358,7 @@ case [ target | UserTargetUnrecognisedUri target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognise URL target '" ++ name ++ "'." | name <- target ] @@ -374,14 +378,14 @@ -> FilePath -> PackageIndex pkg -> [UserTarget] - -> IO [PackageSpecifier SourcePackage] + -> IO [PackageSpecifier UnresolvedSourcePackage] resolveUserTargets verbosity repoCtxt worldFile available userTargets = do -- given the user targets, get a list of fully or partially resolved -- package references packageTargets <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat - =<< mapM (expandUserTarget worldFile) userTargets + =<< mapM (expandUserTarget verbosity worldFile) userTargets -- users are allowed to give package names case-insensitively, so we must -- disambiguate named package references @@ -405,13 +409,13 @@ -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg = - PackageTargetNamed PackageName [PackageConstraint] UserTarget + PackageTargetNamed PackageName [PackageProperty] UserTarget -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget | PackageTargetLocation pkg - deriving Show + deriving (Show, Functor, Foldable, Traversable) -- ------------------------------------------------------------ @@ -421,32 +425,33 @@ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). -- -expandUserTarget :: FilePath +expandUserTarget :: Verbosity + -> FilePath -> UserTarget -> IO [PackageTarget (PackageLocation ())] -expandUserTarget worldFile userTarget = case userTarget of +expandUserTarget verbosity worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> - let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name constraints userTarget] + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] UserTargetWorld -> do - worldPkgs <- World.getContents worldFile + worldPkgs <- World.getContents verbosity worldFile --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name constraints userTarget + return [ PackageTargetNamed name props userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs - , let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - ++ [ PackageConstraintFlags name flags - | not (null flags) ] ] + , let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + ++ [ PackagePropertyFlags flags + | not (null flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalCabalFile file -> do let dir = takeDirectory file - _ <- tryFindPackageDesc dir (localPackageError dir) -- just as a check + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalTarball tarballFile -> @@ -469,13 +474,9 @@ fetchPackageTarget :: Verbosity -> RepoContext -> PackageTarget (PackageLocation ()) - -> IO (PackageTarget (PackageLocation FilePath)) -fetchPackageTarget verbosity repoCtxt target = case target of - PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) - PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) - PackageTargetLocation location -> do - location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location) - return (PackageTargetLocation location') + -> IO (PackageTarget ResolvedPkgLoc) +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) -- | Given a package target that has been fetched, read the .cabal file. @@ -483,28 +484,21 @@ -- This only affects targets given by location, named targets are unaffected. -- readPackageTarget :: Verbosity - -> PackageTarget (PackageLocation FilePath) - -> IO (PackageTarget SourcePackage) -readPackageTarget verbosity target = case target of - - PackageTargetNamed pkgname constraints userTarget -> - return (PackageTargetNamed pkgname constraints userTarget) - - PackageTargetNamedFuzzy pkgname constraints userTarget -> - return (PackageTargetNamedFuzzy pkgname constraints userTarget) - - PackageTargetLocation location -> case location of + -> PackageTarget ResolvedPkgLoc + -> IO (PackageTarget UnresolvedSourcePackage) +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation location = case location of LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc dir (localPackageError dir) >>= - readPackageDescription verbosity - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= + readGenericPackageDescription verbosity + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile @@ -516,26 +510,24 @@ error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. - where readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc case parsePackageDescription' content of - Nothing -> die $ "Could not parse the cabal file " + Nothing -> die' verbosity $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die . formatErr) return + either (die' verbosity . formatErr) return . check . accumEntryMap . Tar.filterEntries isCabalFile @@ -566,11 +558,15 @@ _ -> False parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription +#ifdef CABAL_PARSEC + parsePackageDescription' bs = + parseGenericPackageDescriptionMaybe (BS.toStrict bs) +#else parsePackageDescription' content = - case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of + case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of ParseOk _ pkg -> Just pkg _ -> Nothing - +#endif -- ------------------------------------------------------------ -- * Checking package targets @@ -597,20 +593,18 @@ disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname constraints userTarget + PackageTargetNamed pkgname props userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname constraints) + | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname constraints userTarget -> + PackageTargetNamedFuzzy pkgname props userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left (PackageNameUnknown pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbiguous pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') - where - constraints' = map (renamePackageConstraint pkgname') constraints + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv @@ -626,7 +620,7 @@ case [ pkg | PackageNameUnknown pkg originalTarget <- problems , not (isUserTagetWorld originalTarget) ] of [] -> return () - pkgs -> die $ unlines + pkgs -> die' verbosity $ unlines [ "There is no package named '" ++ display name ++ "'. " | name <- pkgs ] ++ "You may need to run 'cabal update' to get the latest " @@ -634,7 +628,7 @@ case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of [] -> return () - ambiguities -> die $ unlines + ambiguities -> die' verbosity $ unlines [ "The package name '" ++ display name ++ "' is ambiguous. It could be: " ++ intercalate ", " (map display matches) @@ -679,66 +673,91 @@ instance Monoid PackageNameEnv where mempty = PackageNameEnv (const []) - mappend = (Semi.<>) + mappend = (<>) -instance Semi.Semigroup PackageNameEnv where +instance Semigroup PackageNameEnv where PackageNameEnv lookupA <> PackageNameEnv lookupB = PackageNameEnv (\name -> lookupA name ++ lookupB name) indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup where - pkgNameLookup (PackageName name) = - map fst (PackageIndex.searchByName pkgIndex name) + pkgNameLookup pname = + map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup where - pkgNameLookup (PackageName name) = - [ PackageName name' - | let lname = lowercase name - , PackageName name' <- names - , lowercase name' == lname ] + pkgNameLookup pname = + [ pname' + | let lname = lowercase (unPackageName pname) + , pname' <- names + , lowercase (unPackageName pname') == lname ] -- ------------------------------------------------------------ -- * Package constraints -- ------------------------------------------------------------ -data UserConstraint = - UserConstraintVersion PackageName VersionRange - | UserConstraintInstalled PackageName - | UserConstraintSource PackageName - | UserConstraintFlags PackageName FlagAssignment - | UserConstraintStanzas PackageName [OptionalStanza] +-- | Version of 'Qualifier' that a user may specify on the +-- command line. +data UserQualifier = + -- | Top-level dependency. + UserQualToplevel + + -- | Setup dependency. + | UserQualSetup PackageName + + -- | Executable dependency. + | UserQualExe PackageName PackageName deriving (Eq, Show, Generic) +instance Binary UserQualifier + +-- | Version of 'ConstraintScope' that a user may specify on the +-- command line. +data UserConstraintScope = + -- | Scope that applies to the package when it has the specified qualifier. + UserQualified UserQualifier PackageName + + -- | Scope that applies to the package when it has a setup qualifier. + | UserAnySetupQualifier PackageName + + -- | Scope that applies to the package when it has any qualifier. + | UserAnyQualifier PackageName + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope + +fromUserQualifier :: UserQualifier -> Qualifier +fromUserQualifier UserQualToplevel = QualToplevel +fromUserQualifier (UserQualSetup name) = QualSetup name +fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 + +fromUserConstraintScope :: UserConstraintScope -> ConstraintScope +fromUserConstraintScope (UserQualified q pn) = + ScopeQualified (fromUserQualifier q) pn +fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn +fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn + +-- | Version of 'PackageConstraint' that the user can specify on +-- the command line. +data UserConstraint = + UserConstraint UserConstraintScope PackageProperty + deriving (Eq, Show, Generic) + instance Binary UserConstraint userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName uc = case uc of - UserConstraintVersion name _ -> name - UserConstraintInstalled name -> name - UserConstraintSource name -> name - UserConstraintFlags name _ -> name - UserConstraintStanzas name _ -> name +userConstraintPackageName (UserConstraint scope _) = scopePN scope + where + scopePN (UserQualified _ pn) = pn + scopePN (UserAnyQualifier pn) = pn + scopePN (UserAnySetupQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint --- At the moment, the types happen to be directly equivalent -userToPackageConstraint uc = case uc of - UserConstraintVersion name ver -> PackageConstraintVersion name ver - UserConstraintInstalled name -> PackageConstraintInstalled name - UserConstraintSource name -> PackageConstraintSource name - UserConstraintFlags name flags -> PackageConstraintFlags name flags - UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas - -renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint -renamePackageConstraint name pc = case pc of - PackageConstraintVersion _ ver -> PackageConstraintVersion name ver - PackageConstraintInstalled _ -> PackageConstraintInstalled name - PackageConstraintSource _ -> PackageConstraintSource name - PackageConstraintFlags _ flags -> PackageConstraintFlags name flags - PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas +userToPackageConstraint (UserConstraint scope prop) = + PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = @@ -747,72 +766,64 @@ Just c -> Right c where msgCannotParse = - "expected a package name followed by a constraint, which is " - ++ "either a version range, 'installed', 'source' or flags" + "expected a (possibly qualified) package name followed by a " ++ + "constraint, which is either a version range, 'installed', " ++ + "'source', 'test', 'bench', or flags" instance Text UserConstraint where - disp (UserConstraintVersion pkgname verrange) = disp pkgname - <+> disp verrange - disp (UserConstraintInstalled pkgname) = disp pkgname - <+> Disp.text "installed" - disp (UserConstraintSource pkgname) = disp pkgname - <+> Disp.text "source" - disp (UserConstraintFlags pkgname flags) = disp pkgname - <+> dispFlagAssignment flags - disp (UserConstraintStanzas pkgname stanzas) = disp pkgname - <+> dispStanzas stanzas - where - dispStanzas = Disp.hsep . map dispStanza - dispStanza TestStanzas = Disp.text "test" - dispStanza BenchStanzas = Disp.text "bench" - - parse = parse >>= parseConstraint - where - parseConstraint pkgname = - ((parse >>= return . UserConstraintVersion pkgname) - +++ (do skipSpaces1 - _ <- Parse.string "installed" - return (UserConstraintInstalled pkgname)) - +++ (do skipSpaces1 - _ <- Parse.string "source" - return (UserConstraintSource pkgname)) - +++ (do skipSpaces1 - _ <- Parse.string "test" - return (UserConstraintStanzas pkgname [TestStanzas])) - +++ (do skipSpaces1 - _ <- Parse.string "bench" - return (UserConstraintStanzas pkgname [BenchStanzas]))) - <++ (do skipSpaces1 - flags <- parseFlagAssignment - return (UserConstraintFlags pkgname flags)) - ---TODO: [code cleanup] move these somewhere else -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map dispFlagValue - where - dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f - dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f - dispFlagName (FlagName f) = Disp.text f - -parseFlagAssignment :: Parse.ReadP r FlagAssignment -parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1 - where - parseFlagValue = - (do Parse.optional (Parse.char '+') - f <- parseFlagName - return (f, True)) - +++ (do _ <- Parse.char '-' - f <- parseFlagName - return (f, False)) - parseFlagName = liftM (FlagName . lowercase) ident - - ident :: Parse.ReadP r String - ident = Parse.munch1 identChar >>= \s -> check s >> return s - where - identChar c = isAlphaNum c || c == '_' || c == '-' - check ('-':_) = Parse.pfail - check _ = return () - -skipSpaces1 :: Parse.ReadP r () -skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces + disp (UserConstraint scope prop) = + dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + + parse = + let parseConstraintScope :: Parse.ReadP a UserConstraintScope + parseConstraintScope = + do + _ <- Parse.string "any." + pn <- parse + return (UserAnyQualifier pn) + +++ + do + _ <- Parse.string "setup." + pn <- parse + return (UserAnySetupQualifier pn) + +++ + do + -- Qualified name + pn <- parse + (return (UserQualified UserQualToplevel pn) + +++ + do _ <- Parse.string ":setup." + pn2 <- parse + return (UserQualified (UserQualSetup pn) pn2)) + -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax. + -- + -- +++ + -- do _ <- Parse.string ":" + -- pn2 <- parse + -- _ <- Parse.string ":exe." + -- pn3 <- parse + -- return (UserQualExe pn pn2, pn3) + in do + scope <- parseConstraintScope + + -- Package property + let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x + prop <- ((parse >>= return . PackagePropertyVersion) + +++ + keyword "installed" PackagePropertyInstalled + +++ + keyword "source" PackagePropertySource + +++ + keyword "test" (PackagePropertyStanzas [TestStanzas]) + +++ + keyword "bench" (PackagePropertyStanzas [BenchStanzas])) + -- Note: the parser is left-biased here so that we + -- don't get an ambiguous parse from 'installed', + -- 'source', etc. being regarded as flags. + <++ + (Parse.skipSpaces1 >> parseFlagAssignment + >>= return . PackagePropertyFlags) + + -- Result + return (UserConstraint scope prop) diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -19,30 +21,44 @@ module Distribution.Client.Types where import Distribution.Package - ( PackageName, PackageId, Package(..) - , UnitId(..), mkUnitId - , HasUnitId(..), PackageInstalled(..) ) + ( Package(..), HasMungedPackageId(..), HasUnitId(..) + , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) + ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription - ( Benchmark(..), GenericPackageDescription(..), FlagAssignment - , TestSuite(..) ) -import Distribution.PackageDescription.Configuration - ( mapTreeData ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Client.ComponentDeps - ( ComponentDeps ) -import qualified Distribution.Client.ComponentDeps as CD + ( FlagAssignment ) import Distribution.Version ( VersionRange ) -import Distribution.Text (display) +import Distribution.Types.ComponentId + ( ComponentId ) +import Distribution.Types.MungedPackageId + ( computeCompatPackageId ) +import Distribution.Types.PackageId + ( PackageId ) +import Distribution.Types.AnnotatedId +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.PackageName + ( PackageName ) +import Distribution.Types.ComponentName + ( ComponentName(..) ) +import Distribution.Solver.Types.PackageIndex + ( PackageIndex ) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps + ( ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.SourcePackage +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Utils (ordNub) + import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) -import Data.ByteString.Lazy (ByteString) import Control.Exception - ( SomeException ) + ( Exception, SomeException ) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) @@ -53,7 +69,7 @@ -- | This is the information we get from a @00-index.tar.gz@ hackage index. -- data SourcePackageDb = SourcePackageDb { - packageIndex :: PackageIndex SourcePackage, + packageIndex :: PackageIndex UnresolvedSourcePackage, packagePreferences :: Map PackageName VersionRange } deriving (Eq, Generic) @@ -75,160 +91,131 @@ -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler. -- -type InstalledPackageId = UnitId - -installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId -installedPackageId = installedUnitId - --- | Subclass of packages that have specific versioned dependencies. --- --- So for example a not-yet-configured package has dependencies on version --- ranges, not specific versions. A configured or an already installed package --- depends on exact versions. Some operations or data structures (like --- dependency graphs) only make sense on this subclass of package types. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> ComponentDeps [UnitId] - -instance PackageFixedDeps InstalledPackageInfo where - depends = CD.fromInstalled . installedDepends +type InstalledPackageId = ComponentId --- | In order to reuse the implementation of PackageIndex which relies on --- 'UnitId', we need to be able to synthesize these IDs prior --- to installation. Eventually, we'll move to a representation of --- 'UnitId' which can be properly computed before compilation --- (of course, it's a bit of a misnomer since the packages are not actually --- installed yet.) In any case, we'll synthesize temporary installed package --- IDs to use as keys during install planning. These should never be written --- out! Additionally, they need to be guaranteed unique within the install --- plan. -fakeUnitId :: PackageId -> UnitId -fakeUnitId = mkUnitId . (".fake."++) . display - -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the -- final configure process will be independent of the environment. -- -data ConfiguredPackage = ConfiguredPackage - SourcePackage -- package info, including repo - FlagAssignment -- complete flag assignment for the package - [OptionalStanza] -- list of enabled optional stanzas for the package - (ComponentDeps [ConfiguredId]) - -- set of exact dependencies (installed or source). - -- These must be consistent with the 'buildDepends' - -- in the 'PackageDescription' that you'd get by - -- applying the flag assignment and optional stanzas. +-- 'ConfiguredPackage' is assumed to not support Backpack. Only the +-- @new-build@ codepath supports Backpack. +-- +data ConfiguredPackage loc = ConfiguredPackage { + confPkgId :: InstalledPackageId, + confPkgSource :: SourcePackage loc, -- package info, including repo + confPkgFlags :: FlagAssignment, -- complete flag assignment for the package + confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package + confPkgDeps :: ComponentDeps [ConfiguredId] + -- set of exact dependencies (installed or source). + -- These must be consistent with the 'buildDepends' + -- in the 'PackageDescription' that you'd get by + -- applying the flag assignment and optional stanzas. + } deriving (Eq, Show, Generic) -instance Binary ConfiguredPackage +-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. +-- This type class is mostly used to conveniently finesse between +-- 'ElaboratedPackage' and 'ElaboratedComponent'. +-- +instance HasConfiguredId (ConfiguredPackage loc) where + configuredId pkg = ConfiguredId (packageId pkg) (Just CLibName) (confPkgId pkg) +-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed +-- to never have a nontrivial 'UnitId' +instance PackageFixedDeps (ConfiguredPackage loc) where + depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps + +instance IsNode (ConfiguredPackage loc) where + type Key (ConfiguredPackage loc) = UnitId + nodeKey = newSimpleUnitId . confPkgId + -- TODO: if we update ConfiguredPackage to support order-only + -- dependencies, need to include those here. + -- NB: have to deduplicate, otherwise the planner gets confused + nodeNeighbors = ordNub . CD.flatDeps . depends + +instance (Binary loc) => Binary (ConfiguredPackage loc) + + -- | A ConfiguredId is a package ID for a configured package. -- --- Once we configure a source package we know it's UnitId --- (at least, in principle, even if we have to fake it currently). It is still +-- Once we configure a source package we know it's UnitId. It is still -- however useful in lots of places to also know the source ID for the package. -- We therefore bundle the two. -- -- An already installed package of course is also "configured" (all it's -- configuration parameters and dependencies have been specified). --- --- TODO: I wonder if it would make sense to promote this datatype to Cabal --- and use it consistently instead of UnitIds? data ConfiguredId = ConfiguredId { confSrcId :: PackageId - , confInstId :: UnitId + , confCompName :: Maybe ComponentName + , confInstId :: ComponentId } - deriving (Eq, Generic) + deriving (Eq, Ord, Generic) +annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId +annotatedIdToConfiguredId aid = ConfiguredId { + confSrcId = ann_pid aid, + confCompName = Just (ann_cname aid), + confInstId = ann_id aid + } + instance Binary ConfiguredId instance Show ConfiguredId where - show = show . confSrcId + show cid = show (confInstId cid) instance Package ConfiguredId where packageId = confSrcId -instance HasUnitId ConfiguredId where - installedUnitId = confInstId - -instance Package ConfiguredPackage where - packageId (ConfiguredPackage pkg _ _ _) = packageId pkg - -instance PackageFixedDeps ConfiguredPackage where - depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps - -instance HasUnitId ConfiguredPackage where - installedUnitId = fakeUnitId . packageId - --- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be --- installed already, hence itself ready to be installed. -data GenericReadyPackage srcpkg ipkg - = ReadyPackage - srcpkg -- see 'ConfiguredPackage'. - (ComponentDeps [ipkg]) -- Installed dependencies. - deriving (Eq, Show, Generic) - -type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo - -instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where - packageId (ReadyPackage srcpkg _deps) = packageId srcpkg - -instance (Package srcpkg, HasUnitId ipkg) => - PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where - depends (ReadyPackage _ deps) = fmap (map installedUnitId) deps - -instance HasUnitId srcpkg => - HasUnitId (GenericReadyPackage srcpkg ipkg) where - installedUnitId (ReadyPackage pkg _) = installedUnitId pkg +instance Package (ConfiguredPackage loc) where + packageId cpkg = packageId (confPkgSource cpkg) -instance (Binary srcpkg, Binary ipkg) => Binary (GenericReadyPackage srcpkg ipkg) +instance HasMungedPackageId (ConfiguredPackage loc) where + mungedId cpkg = computeCompatPackageId (packageId cpkg) Nothing +-- Never has nontrivial UnitId +instance HasUnitId (ConfiguredPackage loc) where + installedUnitId = newSimpleUnitId . confPkgId --- | A package description along with the location of the package sources. --- -data SourcePackage = SourcePackage { - packageInfoId :: PackageId, - packageDescription :: GenericPackageDescription, - packageSource :: PackageLocation (Maybe FilePath), - packageDescrOverride :: PackageDescriptionOverride - } - deriving (Eq, Show, Generic) +instance PackageInstalled (ConfiguredPackage loc) where + installedDepends = CD.flatDeps . depends -instance Binary SourcePackage +class HasConfiguredId a where + configuredId :: a -> ConfiguredId --- | We sometimes need to override the .cabal file in the tarball with --- the newer one from the package index. -type PackageDescriptionOverride = Maybe ByteString +-- NB: This instance is slightly dangerous, in that you'll lose +-- information about the specific UnitId you depended on. +instance HasConfiguredId InstalledPackageInfo where + configuredId ipkg = ConfiguredId (packageId ipkg) + (Just (sourceComponentName ipkg)) + (installedComponentId ipkg) -instance Package SourcePackage where packageId = packageInfoId +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be +-- installed already, hence itself ready to be installed. +newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. + deriving (Eq, Show, Generic, Package, PackageFixedDeps, + HasMungedPackageId, HasUnitId, PackageInstalled, Binary) -data OptionalStanza - = TestStanzas - | BenchStanzas - deriving (Eq, Ord, Enum, Bounded, Show, Generic) +-- Can't newtype derive this +instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg -instance Binary OptionalStanza +type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) -enableStanzas - :: [OptionalStanza] - -> GenericPackageDescription - -> GenericPackageDescription -enableStanzas stanzas gpkg = gpkg - { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg - , condTestSuites = flagTests $ condTestSuites gpkg - } - where - enableTest t = t { testEnabled = TestStanzas `elem` stanzas } - enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas } - flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm)) - flagTests = map (\(n, t) -> (n, mapTreeData enableTest t)) +-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. +type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ +type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) + +type ResolvedPkgLoc = PackageLocation FilePath + data PackageLocation local = -- | An unpacked package in the given dir, or current dir @@ -249,7 +236,7 @@ --TODO: -- * add support for darcs and other SCM style remote repos with a local cache -- | ScmPackage - deriving (Show, Functor, Eq, Ord, Generic) + deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) @@ -341,7 +328,14 @@ -- * Build results -- ------------------------------------------------------------ -type BuildResult = Either BuildFailure BuildSuccess +-- | A summary of the outcome for building a single package. +-- +type BuildOutcome = Either BuildFailure BuildResult + +-- | A summary of the outcome for building a whole set of packages. +-- +type BuildOutcomes = Map UnitId BuildOutcome + data BuildFailure = PlanningFailed | DependentFailed PackageId | DownloadFailed SomeException @@ -350,18 +344,25 @@ | BuildFailed SomeException | TestsFailed SomeException | InstallFailed SomeException - deriving (Show, Generic) -data BuildSuccess = BuildOk DocsResult TestsResult - (Maybe InstalledPackageInfo) + deriving (Show, Typeable, Generic) + +instance Exception BuildFailure + +-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only +-- the public library's 'InstalledPackageInfo' is stored here, even if +-- there were 'InstalledPackageInfo' from internal libraries. This +-- 'InstalledPackageInfo' is not used anyway, so it makes no difference. +data BuildResult = BuildResult DocsResult TestsResult + (Maybe InstalledPackageInfo) deriving (Show, Generic) data DocsResult = DocsNotTried | DocsFailed | DocsOk - deriving (Show, Generic) + deriving (Show, Generic, Typeable) data TestsResult = TestsNotTried | TestsOk - deriving (Show, Generic) + deriving (Show, Generic, Typeable) instance Binary BuildFailure -instance Binary BuildSuccess +instance Binary BuildResult instance Binary DocsResult instance Binary TestsResult diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -47,7 +47,6 @@ warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." update verbosity repoCtxt = do - jobCtrl <- newParallelJobControl let repos = repoContextRepos repoCtxt remoteRepos = catMaybes (map maybeRepoRemote repos) case remoteRepos of @@ -58,6 +57,7 @@ _ -> notice verbosity . unlines $ "Downloading the latest package lists from: " : map (("- " ++) . remoteRepoName) remoteRepos + jobCtrl <- newParallelJobControl (length repos) mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos mapM_ (\_ -> collectJob jobCtrl) repos diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -1,13 +1,13 @@ -module Distribution.Client.Upload (check, upload, uploadDoc, report) where +module Distribution.Client.Upload (upload, uploadDoc, report) where import Distribution.Client.Types ( Username(..), Password(..) , RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup - ( RepoContext(..) ) + ( IsCandidate(..), RepoContext(..) ) -import Distribution.Simple.Utils (notice, warn, info, die) +import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config @@ -15,69 +15,99 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.URI (URI(uriPath), parseURI) +import Network.URI (URI(uriPath)) import Network.HTTP (Header(..), HeaderName(..)) -import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho) +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) import System.Exit (exitFailure) -import Control.Exception (bracket) -import System.FilePath ((), takeExtension, takeFileName) +import System.FilePath ((), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix (()) import System.Directory -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, foldM) import Data.Maybe (catMaybes) +import Data.Char (isSpace) type Auth = Maybe (String, String) -checkURI :: URI -Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/" - ++ "hackage-scripts/check-pkg" +-- > stripExtensions ["tar", "gz"] "foo.tar.gz" +-- Just "foo" +-- > stripExtensions ["tar", "gz"] "foo.gz.tar" +-- Nothing +stripExtensions :: [String] -> FilePath -> Maybe String +stripExtensions exts path = foldM f path (reverse exts) + where + f p e + | takeExtension p == '.':e = Just (dropExtension p) + | otherwise = Nothing upload :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> [FilePath] + -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath] -> IO () -upload verbosity repoCtxt mUsername mPassword paths = do +upload verbosity repoCtxt mUsername mPassword isCandidate paths = do let repos = repoContextRepos repoCtxt transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix. + case isCandidate of + IsCandidate -> "packages/candidates" + IsPublished -> "upload" + } + packageURI pkgid = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. "upload" + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] } Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword let auth = Just (username,password) forM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " - handlePackage transport verbosity uploadURI auth path + case fmap takeFileName (stripExtensions ["tar", "gz"] path) of + Just pkgid -> handlePackage transport verbosity uploadURI + (packageURI pkgid) auth isCandidate path + -- This case shouldn't really happen, since we check in Main that we + -- only pass tar.gz files to upload. + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path uploadDoc :: Verbosity -> RepoContext - -> Maybe Username -> Maybe Password -> FilePath + -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath -> IO () -uploadDoc verbosity repoCtxt mUsername mPassword path = do +uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do let repos = repoContextRepos repoCtxt transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die $ "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { uriPath = rootIfEmpty (uriPath targetRepoURI) - FilePath.Posix. "package/" ++ pkgid ++ "/docs" + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + , "/docs" + ] } (reverseSuffix, reversePkgid) = break (== '-') (reverse (takeFileName path)) pkgid = reverse $ tail reversePkgid when (reverse reverseSuffix /= "docs.tar.gz" || null reversePkgid || head reversePkgid /= '-') $ - die "Expected a file name matching the pattern -docs.tar.gz" + die' verbosity "Expected a file name matching the pattern -docs.tar.gz" Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword @@ -89,7 +119,9 @@ notice verbosity $ "Uploading documentation " ++ path ++ "... " resp <- putHttpFile transport verbosity uploadURI path auth headers case resp of - (200,_) -> + -- Hackage responds with 204 No Content when docs are uploaded + -- successfully. + (code,_) | code `elem` [200,204] -> do notice verbosity "Ok" (code,err) -> do notice verbosity $ "Error uploading documentation " @@ -108,10 +140,8 @@ promptPassword = do putStr "Hackage password: " hFlush stdout - -- save/restore the terminal echoing status - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap Password getLine + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap Password getLine putStrLn "" return passwd @@ -132,7 +162,7 @@ contents <- getDirectoryContents srcDir forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile -> do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = read inp :: (String,String) + let (reportStr, buildLog) = read inp :: (String,String) -- TODO: eradicateNoParse case BuildReport.parse reportStr of Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME Right report' -> @@ -142,22 +172,32 @@ (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () -check :: Verbosity -> RepoContext -> [FilePath] -> IO () -check verbosity repoCtxt paths = do - transport <- repoContextGetTransport repoCtxt - forM_ paths $ \path -> do - notice verbosity $ "Checking " ++ path ++ "... " - handlePackage transport verbosity checkURI Nothing path - -handlePackage :: HttpTransport -> Verbosity -> URI -> Auth - -> FilePath -> IO () -handlePackage transport verbosity uri auth path = +handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth + -> IsCandidate -> FilePath -> IO () +handlePackage transport verbosity uri packageUri auth isCandidate path = do resp <- postHttpFile transport verbosity uri path auth case resp of - (200,_) -> - notice verbosity "Ok" + (code,warnings) | code `elem` [200, 204] -> + notice verbosity $ okMessage isCandidate ++ + if null warnings then "" else "\n" ++ formatWarnings (trim warnings) (code,err) -> do notice verbosity $ "Error uploading " ++ path ++ ": " ++ "http code " ++ show code ++ "\n" ++ err exitFailure + where + okMessage IsCandidate = + "Package successfully uploaded as candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To publish the candidate, use 'cabal upload --publish'." + okMessage IsPublished = + "Package successfully published. You can now view it at '" + ++ show packageUri ++ "'." + +formatWarnings :: String -> String +formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x + +-- Trim +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -3,12 +3,14 @@ module Distribution.Client.Utils ( MergeResult(..) , mergeBy, duplicates, duplicatesBy , readMaybe - , inDir, logDirChange + , inDir, withEnv, logDirChange + , withExtraPathEnv , determineNumJobs, numberOfProcessors , removeExistingFile , withTempFileName , makeAbsoluteToCwd , makeRelativeToCwd, makeRelativeToDir + , makeRelativeCanonical , filePathToByteString , byteStringToFilePath, tryCanonicalizePath , canonicalizePathNoThrow @@ -18,36 +20,27 @@ , relaxEncodingErrors) where +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Compat.Environment import Distribution.Compat.Exception ( catchIO ) -import Distribution.Client.Compat.Time ( getModTime ) +import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Simple.Utils ( die, findPackageDesc ) +import Distribution.Verbosity +import Distribution.Simple.Utils ( die', findPackageDesc ) import qualified Data.ByteString.Lazy as BS -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Control.Monad - ( when ) import Data.Bits ( (.|.), shiftL, shiftR ) -import Data.Char - ( ord, chr ) -#if MIN_VERSION_base(4,6,0) -import Text.Read - ( readMaybe ) -#endif +import System.FilePath import Data.List - ( isPrefixOf, sortBy, groupBy ) -import Data.Word - ( Word8, Word32) + ( groupBy ) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception ( finally, bracket ) import System.Directory ( canonicalizePath, doesFileExist, getCurrentDirectory , removeFile, setCurrentDirectory ) -import System.FilePath - ( (), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0) @@ -64,16 +57,12 @@ #endif #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) -import Prelude hiding (ioError) -import Control.Monad (liftM2, unless) -import System.Directory (doesDirectoryExist) -import System.IO.Error (ioError, mkIOError, doesNotExistErrorType) +import qualified System.Directory as Dir +import qualified System.IO.Error as IOError #endif -- | Generic merging utility. For sorted input lists this is a full outer join. -- --- * The result list never contains @(Nothing, Nothing)@. --- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] mergeBy cmp = merge where @@ -99,14 +88,6 @@ moreThanOne (_:_:_) = True moreThanOne _ = False -#if !MIN_VERSION_base(4,6,0) --- | An implementation of readMaybe, for compatability with older base versions. -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing -#endif - -- | Like 'removeFile', but does not throw an exception when the file does not -- exist. removeExistingFile :: FilePath -> IO () @@ -129,6 +110,9 @@ (\(name, h) -> hClose h >> action name) -- | Executes the action in the specified directory. +-- +-- Warning: This operation is NOT thread-safe, because current +-- working directory is a process-global concept. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do @@ -136,6 +120,36 @@ setCurrentDirectory d m `Exception.finally` setCurrentDirectory old +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: String -> String -> IO a -> IO a +withEnv k v m = do + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` (case mb_old of + Nothing -> unsetEnv k + Just old -> setEnv k old) + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: [FilePath] -> IO a -> IO a +withExtraPathEnv paths m = do + oldPathSplit <- getSearchPath + let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + -- | Log directory change in 'make' compatible syntax logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m @@ -231,9 +245,9 @@ tryCanonicalizePath path = do ret <- canonicalizePath path #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) - exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret) + exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret) unless exists $ - ioError $ mkIOError doesNotExistErrorType "canonicalizePath" + IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath" Nothing (Just ret) #endif return ret @@ -285,17 +299,17 @@ return () -- |Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $ +tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " ++ depPath -- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be -- found, with @err@ prefixing the error message. This function simply allows -- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: FilePath -> String -> IO FilePath -tryFindPackageDesc depPath err = do +tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindPackageDesc verbosity depPath err = do errOrCabalFile <- findPackageDesc depPath case errOrCabalFile of Right file -> return file - Left _ -> die err + Left _ -> die' verbosity err diff --git a/Distribution/Client/Utils/Assertion.hs b/Distribution/Client/Utils/Assertion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Utils/Assertion.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Utils.Assertion (expensiveAssert) where + +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +import Control.Exception (assert) +import Distribution.Compat.Stack +#endif + +-- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This +-- function can be used for expensive assertions that should only be turned on +-- during testing or debugging. +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +expensiveAssert :: WithCallStack (Bool -> a -> a) +expensiveAssert = assert +#else +expensiveAssert :: Bool -> a -> a +expensiveAssert _ = id +#endif diff --git a/Distribution/Client/Utils/LabeledGraph.hs b/Distribution/Client/Utils/LabeledGraph.hs deleted file mode 100644 --- a/Distribution/Client/Utils/LabeledGraph.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | Wrapper around Data.Graph with support for edge labels -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Client.Utils.LabeledGraph ( - -- * Graphs - Graph - , Vertex - -- ** Building graphs - , graphFromEdges - , graphFromEdges' - , buildG - , transposeG - -- ** Graph properties - , vertices - , edges - -- ** Operations on the underlying unlabeled graph - , forgetLabels - , topSort - ) where - -import Data.Array -import Data.Graph (Vertex, Bounds) -import Data.List (sortBy) -import Data.Maybe (mapMaybe) -import qualified Data.Graph as G - -{------------------------------------------------------------------------------- - Types --------------------------------------------------------------------------------} - -type Graph e = Array Vertex [(e, Vertex)] -type Edge e = (Vertex, e, Vertex) - -{------------------------------------------------------------------------------- - Building graphs --------------------------------------------------------------------------------} - --- | Construct an edge-labeled graph --- --- This is a simple adaptation of the definition in Data.Graph -graphFromEdges :: forall key node edge. Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - , key -> Maybe Vertex - ) -graphFromEdges edges0 = - (graph, \v -> vertex_map ! v, key_vertex) - where - max_v = length edges0 - 1 - bounds0 = (0, max_v) :: (Vertex, Vertex) - sorted_edges = sortBy lt edges0 - edges1 = zipWith (,) [0..] sorted_edges - - graph = array bounds0 [(v, (mapMaybe mk_edge ks)) - | (v, (_, _, ks)) <- edges1] - key_map = array bounds0 [(v, k ) - | (v, (_, k, _ )) <- edges1] - vertex_map = array bounds0 edges1 - - (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 - - mk_edge :: (edge, key) -> Maybe (edge, Vertex) - mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) - - -- returns Nothing for non-interesting vertices - key_vertex :: key -> Maybe Vertex - key_vertex k = findVertex 0 max_v - where - findVertex a b - | a > b = Nothing - | otherwise = case compare k (key_map ! mid) of - LT -> findVertex a (mid-1) - EQ -> Just mid - GT -> findVertex (mid+1) b - where - mid = a + (b - a) `div` 2 - -graphFromEdges' :: Ord key - => [ (node, key, [(edge, key)]) ] - -> ( Graph edge - , Vertex -> (node, key, [(edge, key)]) - ) -graphFromEdges' x = (a,b) - where - (a,b,_) = graphFromEdges x - -transposeG :: Graph e -> Graph e -transposeG g = buildG (bounds g) (reverseE g) - -buildG :: Bounds -> [Edge e] -> Graph e -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where - reassoc (v, e, w) = (v, (e, w)) - -reverseE :: Graph e -> [Edge e] -reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] - -{------------------------------------------------------------------------------- - Graph properties --------------------------------------------------------------------------------} - -vertices :: Graph e -> [Vertex] -vertices = indices - -edges :: Graph e -> [Edge e] -edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] - -{------------------------------------------------------------------------------- - Operations on the underlying unlabelled graph --------------------------------------------------------------------------------} - -forgetLabels :: Graph e -> G.Graph -forgetLabels = fmap (map snd) - -topSort :: Graph e -> [Vertex] -topSort = G.topSort . forgetLabels diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs --- a/Distribution/Client/Win32SelfUpgrade.hs +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -42,7 +42,7 @@ deleteOldExeFile, ) where -#if mingw32_HOST_OS +#ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) @@ -212,7 +212,7 @@ #else import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') possibleSelfUpgrade :: Verbosity -> [FilePath] @@ -220,6 +220,6 @@ possibleSelfUpgrade _ _ action = action deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" +deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" #endif diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -29,14 +29,13 @@ getContents, ) where -import Distribution.Package - ( Dependency(..) ) +import Distribution.Types.Dependency import Distribution.PackageDescription - ( FlagAssignment, FlagName(FlagName) ) + ( FlagAssignment, mkFlagName, unFlagName ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( die, info, chattyTry, writeFileAtomic ) + ( die', info, chattyTry, writeFileAtomic ) import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse @@ -91,7 +90,7 @@ modifyWorld _ _ _ [] = return () modifyWorld f verbosity world pkgs = chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents world + pkgsOldWorld <- getContents verbosity world -- Filter out packages that are not in the world file: let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld -- 'Dependency' is not an Ord instance, so we need to check for @@ -107,12 +106,12 @@ -- | Returns the content of the world file as a list -getContents :: FilePath -> IO [WorldPkgInfo] -getContents world = do +getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] +getContents verbosity world = do content <- safelyReadFile world let result = map simpleParse (lines $ B.unpack content) case sequence result of - Nothing -> die "Could not parse world file." + Nothing -> die' verbosity "Could not parse world file." Just xs -> return xs where safelyReadFile :: FilePath -> IO B.ByteString @@ -128,10 +127,10 @@ dispFlags [] = Disp.empty dispFlags fs = Disp.text "--flags=" <> Disp.doubleQuotes (flagAssToDoc fs) - flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> + flagAssToDoc = foldr (\(fname,val) flagAssDoc -> (if not val then Disp.char '-' else Disp.empty) - Disp.<> Disp.text fname + Disp.<> Disp.text (unFlagName fname) Disp.<+> flagAssDoc) Disp.empty parse = do @@ -156,7 +155,7 @@ val <- negative Parse.+++ positive name <- ident Parse.skipSpaces - return (FlagName name,val) + return (mkFlagName name,val) negative = do _ <- Parse.char '-' return False diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular.hs @@ -0,0 +1,60 @@ +module Distribution.Solver.Modular + ( modularResolver, SolverConfig(..)) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Data.Map as M + ( fromListWith ) +import Distribution.Compat.Graph + ( IsNode(..) ) +import Distribution.Solver.Modular.Assignment + ( toCPs ) +import Distribution.Solver.Modular.ConfiguredConversion + ( convCP ) +import Distribution.Solver.Modular.IndexConversion + ( convPIs ) +import Distribution.Solver.Modular.Log + ( logToProgress ) +import Distribution.Solver.Modular.Package + ( PN ) +import Distribution.Solver.Modular.Solver + ( SolverConfig(..), solve ) +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.DependencyResolver +import Distribution.System + ( Platform(..) ) +import Distribution.Simple.Utils + ( ordNubBy ) + + +-- | Ties the two worlds together: classic cabal-install vs. the modular +-- solver. Performs the necessary translations before and after. +modularResolver :: SolverConfig -> DependencyResolver loc +modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = + fmap (uncurry postprocess) $ -- convert install plan + logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format + solve sc cinfo idx pkgConfigDB pprefs gcs pns + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map pair pcs) + where + pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) + + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + postprocess a rdm = ordNubBy nodeKey $ + map (convCP iidx sidx) (toCPs a rdm) + + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraint scope _) = scopeToPackageName scope diff --git a/Distribution/Solver/Modular/Assignment.hs b/Distribution/Solver/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Assignment.hs @@ -0,0 +1,152 @@ +module Distribution.Solver.Modular.Assignment + ( Assignment(..) + , FAssignment + , SAssignment + , PreAssignment(..) + , extend + , toCPs + ) where + +import Control.Applicative +import Control.Monad +import Data.Array as A +import Data.List as L +import Data.Map as M +import Data.Maybe +import Prelude hiding (pi) + +import Language.Haskell.Extension (Extension, Language) + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import Distribution.Solver.Modular.Configured +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.LabeledGraph +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Version + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +-- | A (partial) package preassignment. Qualified package names +-- are associated with constrained instances. Constrained instances +-- record constraints about the instances that can still be chosen, +-- and in the extreme case fix a concrete instance. +type PPreAssignment = Map QPN (CI QPN) +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: (Extension -> Bool) -- ^ is a given extension supported + -> (Language -> Bool) -- ^ is a given language supported + -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> Var QPN + -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet, [Dep QPN]) PPreAssignment +extend extSupported langSupported pkgPresent var = foldM extendSingle + where + + extendSingle :: PPreAssignment -> Dep QPN + -> Either (ConflictSet, [Dep QPN]) PPreAssignment + extendSingle a (Ext ext ) = + if extSupported ext then Right a + else Left (varToConflictSet var, [Ext ext]) + extendSingle a (Lang lang) = + if langSupported lang then Right a + else Left (varToConflictSet var, [Lang lang]) + extendSingle a (Pkg pn vr) = + if pkgPresent pn vr then Right a + else Left (varToConflictSet var, [Pkg pn vr]) + extendSingle a (Dep is_exe qpn ci) = + let ci' = M.findWithDefault (Constrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge ci' ci of + Left (c, (d, d')) -> Left (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d')) + Right x -> Right x + + -- We're trying to remove trivial elements of the conflict. If we're just + -- making a choice pkg == instance, and pkg => pkg == instance is a part + -- of the conflict, then this info is clear from the context and does not + -- have to be repeated. + simplify v (Fixed _ var') c | v == var && var' == var = [c] + simplify v c (Fixed _ var') | v == var && var' == var = [c] + simplify _ c d = [c, d] + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph Component + vm :: Vertex -> ((), QPN, [(Component, QPN)]) + cvm :: QPN -> Maybe Vertex + -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. + (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) + (M.toList rdm)) + tg :: Graph Component + tg = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith (++) $ + L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN [OptionalStanza] + sapp = M.fromListWith (++) $ + L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + M.toList $ + sa + -- Dependencies per package. + depp :: QPN -> [(Component, PI QPN)] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) + dvs :: [(Component, Vertex)] + dvs = tg A.! v + in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs + -- Translated to PackageDeps + depp' :: QPN -> ComponentDeps [PI QPN] + depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault [] qpn fapp) + (M.findWithDefault [] qpn sapp) + (depp' qpn)) + ps diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Builder (buildTree) where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import Data.List as L +import Data.Map as M +import Prelude hiding (sequence, mapM) + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.PSQ (PSQ) +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings + +-- | All state needed to build and link the search tree. It has a type variable +-- because the linking phase doesn't need to know about the state used to build +-- the tree. +data Linker a = Linker { + buildState :: a, + linkingState :: LinkingState +} + +-- | The state needed to build the search tree without creating any linked nodes. +data BuildState = BS { + index :: Index, -- ^ information about packages and their dependencies + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals) + next :: BuildType, -- ^ kind of node to generate next + qualifyOptions :: QualifyOptions -- ^ qualification options +} + +-- | Map of available linking targets. +type LinkingState = Map (PN, I) [PackagePath] + +-- | Extend the set of open goals with the new goals listed. +-- +-- We also adjust the map of overall goals, and keep track of the +-- reverse dependencies of each of the goals. +extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState +extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs + where + go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState + go g o [] = s { rdeps = g, open = o } + go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs + go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs) + | qpn == qpn' = go g o ngs + -- we ignore self-dependencies at this point; TODO: more care may be needed + | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs + | otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs + -- code above is correct; insert/adjust have different arg order + go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs + go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs + go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs + + cons' = P.cons . forgetCompOpenGoal + + addIfAbsent :: Eq a => a -> [a] -> [a] + addIfAbsent x xs = if x `elem` xs then xs else x : xs + +-- | Given the current scope, qualify all the package names in the given set of +-- dependencies and then extend the set of open goals accordingly. +scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo -> + BuildState -> BuildState +scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s + where + -- Qualify all package names + qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps + -- Introduce all package flags + qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs + -- Combine new package and flag goals + gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) + -- NOTE: + -- + -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially + -- multiple times, both via the flag declaration and via dependencies. + -- The order is potentially important, because the occurrences via + -- dependencies may record flag-dependency information. After a number + -- of bugs involving computing this information incorrectly, however, + -- we're currently not using carefully computed inter-flag dependencies + -- anymore, but instead use 'simplifyVar' when computing conflict sets + -- to map all flags of one package to a single flag for conflict set + -- purposes, thereby treating them all as interdependent. + -- + -- If we ever move to a more clever algorithm again, then the line above + -- needs to be looked at very carefully, and probably be replaced by + -- more systematically computed flag dependency information. + +-- | Datatype that encodes what to build next +data BuildType = + Goals -- ^ build a goal choice node + | OneGoal (OpenGoal ()) -- ^ build a node for this goal + | Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance + deriving Show + +build :: Linker BuildState -> Tree () QGoalReason +build = ana go + where + go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) + go s = addLinking (linkingState s) $ addChildren (buildState s) + +addChildren :: BuildState -> TreeF () QGoalReason BuildState + +-- If we have a choice between many goals, we just record the choice in +-- the tree. We select each open goal in turn, and before we descend, remove +-- it from the queue of open goals. +addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + | P.null gs = DoneF rdm () + | otherwise = GoalChoiceF rdm $ P.mapKeys close + $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) + $ P.splits gs + +-- If we have already picked a goal, then the choice depends on the kind +-- of goal. +-- +-- For a package, we look up the instances available in the global info, +-- and then handle each instance in turn. +addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) = + error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal" +addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) = + error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal" +addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = + error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal" +addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) = + -- If the package does not exist in the index, we construct an emty PChoiceF node for it + -- After all, we have no choices here. Alternatively, we could immediately construct + -- a Fail node here, but that would complicate the construction of conflict sets. + -- We will probably want to give this case special treatment when generating error + -- messages though. + case M.lookup pn idx of + Nothing -> PChoiceF qpn rdm gr (W.fromList []) + Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> + ([], POption i Nothing, bs { next = Instance qpn i info gr })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here + +-- For a flag, we create only two subtrees, and we create them in the order +-- that is indicated by the flag default. +addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = + FChoiceF qfn rdm gr weak m b (W.fromList + [([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }), + ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]) + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial + +-- For a stanza, we also create only two subtrees. The order is initially +-- False, True. This can be changed later by constraints (force enabling +-- the stanza by replacing the False branch with failure) or preferences +-- (try enabling the stanza if possible by moving the True branch first). + +addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = + SChoiceF qsn rdm gr trivial (W.fromList + [([0], False, bs { next = Goals }), + ([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })]) + where + trivial = WeakOrTrivial (L.null t) + +-- For a particular instance, we change the state: we update the scope, +-- and furthermore we update the set of goals. +-- +-- TODO: We could inline this above. +addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) = + addChildren ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs) + { next = Goals }) + +{------------------------------------------------------------------------------- + Add linking +-------------------------------------------------------------------------------} + +-- | Introduce link nodes into the tree +-- +-- Linking is a phase that adapts package choice nodes and adds the option to +-- link wherever appropriate: Package goals are called "related" if they are for +-- the same instance of the same package (but have different prefixes). A link +-- option is available in a package choice node whenever we can choose an +-- instance that has already been chosen for a related goal at a higher position +-- in the tree. We only create link options for related goals that are not +-- themselves linked, because the choice to link to a linked goal is the same as +-- the choice to link to the target of that goal's linking. +-- +-- The code here proceeds by maintaining a finite map recording choices that +-- have been made at higher positions in the tree. For each pair of package name +-- and instance, it stores the prefixes at which we have made a choice for this +-- package instance. Whenever we make an unlinked choice, we extend the map. +-- Whenever we find a choice, we look into the map in order to find out what +-- link options we have to add. +-- +-- A separate tree traversal would be simpler. However, 'addLinking' creates +-- linked nodes from existing unlinked nodes, which leads to sharing between the +-- nodes. If we copied the nodes when they were full trees of type +-- 'Tree () QGoalReason', then the sharing would cause a space leak during +-- exploration of the tree. Instead, we only copy the 'BuildState', which is +-- relatively small, while the tree is being constructed. See +-- https://github.com/haskell/cabal/issues/2899 +addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) +-- The only nodes of interest are package nodes +addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = + let linkedCs = fmap (\bs -> Linker bs ls) $ + W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) + unlinkedCs = W.mapWithKey goP cs + allCs = unlinkedCs `W.union` linkedCs + + -- Recurse underneath package choices. Here we just need to make sure + -- that we record the package choice so that it is available below + goP :: POption -> a -> Linker a + goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls + goP _ _ = alreadyLinked + in PChoiceF qpn rdm gr allCs +addLinking ls t = fmap (\bs -> Linker bs ls) t + +linkChoices :: forall a w . LinkingState + -> QPN + -> (w, POption, a) + -> [(w, POption, a)] +linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = + L.map aux (M.findWithDefault [] (pn, i) related) + where + aux :: PackagePath -> (w, POption, a) + aux pp = (weight, POption i (Just pp), subtree) +linkChoices _ _ (_, POption _ (Just _), _) = + alreadyLinked + +alreadyLinked :: a +alreadyLinked = error "addLinking called on tree that already contains linked nodes" + +------------------------------------------------------------------------------- + +-- | Interface to the tree builder. Just takes an index and a list of package names, +-- and computes the initial state and then the tree from there. +buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason +buildTree idx (IndependentGoals ind) igs = + build Linker { + buildState = BS { + index = idx + , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) + , open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns) + , next = Goals + , qualifyOptions = defaultQualifyOptions idx + } + , linkingState = M.empty + } + where + -- Should a top-level goal allowed to be an executable style + -- dependency? Well, I don't think it would make much difference + topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal + + qpns | ind = makeIndependent igs + | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs diff --git a/Distribution/Solver/Modular/Configured.hs b/Distribution/Solver/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Configured.hs @@ -0,0 +1,13 @@ +module Distribution.Solver.Modular.Configured + ( CP(..) + ) where + +import Distribution.PackageDescription (FlagAssignment) + +import Distribution.Solver.Modular.Package +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.OptionalStanza + +-- | A configured package is a package instance together with +-- a flag assignment and complete dependencies. +data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn]) diff --git a/Distribution/Solver/Modular/ConfiguredConversion.hs b/Distribution/Solver/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -0,0 +1,72 @@ +module Distribution.Solver.Modular.ConfiguredConversion + ( convCP + ) where + +import Data.Maybe +import Prelude hiding (pi) +import Data.Either (partitionEithers) + +import Distribution.Package (UnitId, packageId) + +import qualified Distribution.Simple.PackageIndex as SI + +import Distribution.Solver.Modular.Configured +import Distribution.Solver.Modular.Package + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.PackageIndex as CI +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage + +-- | Converts from the solver specific result @CP QPN@ into +-- a 'ResolverPackage', which can then be converted into +-- the install plan. +convCP :: SI.InstalledPackageIndex -> + CI.PackageIndex (SourcePackage loc) -> + CP QPN -> ResolverPackage loc +convCP iidx sidx (CP qpi fa es ds) = + case convPI qpi of + Left pi -> PreExisting $ + InstSolverPackage { + instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverPkgLibDeps = fmap fst ds', + instSolverPkgExeDeps = fmap snd ds' + } + Right pi -> Configured $ + SolverPackage { + solverPkgSource = srcpkg, + solverPkgFlags = fa, + solverPkgStanzas = es, + solverPkgLibDeps = fmap fst ds', + solverPkgExeDeps = fmap snd ds' + } + where + Just srcpkg = CI.lookupPackageId sidx pi + where + ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) + ds' = fmap (partitionEithers . map convConfId) ds + +convPI :: PI QPN -> Either UnitId PackageId +convPI (PI _ (I _ (Inst pi))) = Left pi +convPI pi = Right (packageId (either id id (convConfId pi))) + +convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} +convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = + case loc of + Inst pi -> Left (PreExistingId sourceId pi) + _otherwise + | QualExe _ pn' <- q + -- NB: the dependencies of the executable are also + -- qualified. So the way to tell if this is an executable + -- dependency is to make sure the qualifier is pointing + -- at the actual thing. Fortunately for us, I was + -- silly and didn't allow arbitrarily nested build-tools + -- dependencies, so a shallow check works. + , pn == pn' -> Right (PlannedId sourceId) + | otherwise -> Left (PlannedId sourceId) + where + sourceId = PackageIdentifier pn v diff --git a/Distribution/Solver/Modular/ConflictSet.hs b/Distribution/Solver/Modular/ConflictSet.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/ConflictSet.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +-- | Conflict sets +-- +-- Intended for double import +-- +-- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) +-- > import qualified Distribution.Solver.Modular.ConflictSet as CS +module Distribution.Solver.Modular.ConflictSet ( + ConflictSet -- opaque + , ConflictMap +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin +#endif + , showConflictSet + , showCSSortedByFrequency + , showCSWithFrequency + -- Set-like operations + , toList + , union + , unions + , insert + , empty + , singleton + , member + , filter + , fromList + ) where + +import Prelude hiding (filter) +import Data.List (intercalate, sortBy) +import Data.Map (Map) +import Data.Set (Set) +import Data.Function (on) +import qualified Data.Set as S +import qualified Data.Map as M + +#ifdef DEBUG_CONFLICT_SETS +import Data.Tree +import GHC.Stack +#endif + +import Distribution.Solver.Modular.Var +import Distribution.Solver.Types.PackagePath + +-- | The set of variables involved in a solver conflict +-- +-- Since these variables should be preprocessed in some way, this type is +-- kept abstract. +data ConflictSet = CS { + -- | The set of variables involved on the conflict + conflictSetToSet :: Set (Var QPN) + +#ifdef DEBUG_CONFLICT_SETS + -- | The origin of the conflict set + -- + -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@, + -- we record the origin of every conflict set. For new conflict sets + -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations + -- that construct new conflict sets from existing conflict sets ('union', + -- 'filter', ..) we record the 'CallStack' to the call to the combinator + -- as well as the 'CallStack's of the input conflict sets. + -- + -- Requires @GHC >= 7.10@. + , conflictSetOrigin :: Tree CallStack +#endif + } + deriving (Show) + +instance Eq ConflictSet where + (==) = (==) `on` conflictSetToSet + +instance Ord ConflictSet where + compare = compare `on` conflictSetToSet + +showConflictSet :: ConflictSet -> String +showConflictSet = intercalate ", " . map showVar . toList + +showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String +showCSSortedByFrequency = showCS False + +showCSWithFrequency :: ConflictMap -> ConflictSet -> String +showCSWithFrequency = showCS True + +showCS :: Bool -> ConflictMap -> ConflictSet -> String +showCS showCount cm = + intercalate ", " . map showWithFrequency . indexByFrequency + where + indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList + showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of + Just frequency + | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" + _ -> showVar conflict + +{------------------------------------------------------------------------------- + Set-like operations +-------------------------------------------------------------------------------} + +toList :: ConflictSet -> [Var QPN] +toList = S.toList . conflictSetToSet + +union :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet -> ConflictSet -> ConflictSet +union cs cs' = CS { + conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs') +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) +#endif + } + +unions :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [ConflictSet] -> ConflictSet +unions css = CS { + conflictSetToSet = S.unions (map conflictSetToSet css) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) +#endif + } + +insert :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet -> ConflictSet +insert var cs = CS { + conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] +#endif + } + +empty :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + ConflictSet +empty = CS { + conflictSetToSet = S.empty +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +singleton :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> ConflictSet +singleton var = CS { + conflictSetToSet = S.singleton (simplifyVar var) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +member :: Var QPN -> ConflictSet -> Bool +member var = S.member (simplifyVar var) . conflictSetToSet + +filter :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + (Var QPN -> Bool) -> ConflictSet -> ConflictSet +filter p cs = CS { + conflictSetToSet = S.filter p (conflictSetToSet cs) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] +#endif + } + +fromList :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + [Var QPN] -> ConflictSet +fromList vars = CS { + conflictSetToSet = S.fromList (map simplifyVar vars) +#ifdef DEBUG_CONFLICT_SETS + , conflictSetOrigin = Node ?loc [] +#endif + } + +type ConflictMap = Map (Var QPN) Int + diff --git a/Distribution/Solver/Modular/Cycles.hs b/Distribution/Solver/Modular/Cycles.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Cycles.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TypeFamilies #-} +module Distribution.Solver.Modular.Cycles ( + detectCyclesPhase + ) where + +import Prelude hiding (cycle) +import qualified Data.Map as M +import qualified Data.Set as S + +import qualified Distribution.Compat.Graph as G +import Distribution.Simple.Utils (ordNub) +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Solver.Types.PackagePath + +-- | Find and reject any nodes with cyclic dependencies +detectCyclesPhase :: Tree d c -> Tree d c +detectCyclesPhase = cata go + where + -- Only check children of choice nodes. + go :: TreeF d c (Tree d c) -> Tree d c + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr $ fmap (checkChild qpn) cs + go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m d cs) = + FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs + go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) = + SChoice qsn rdm gr w $ fmap (checkChild qpn) cs + go x = inn x + + checkChild :: QPN -> Tree d c -> Tree d c + checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x + checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x + checkChild _ x@(Fail _ _) = x + checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x + + failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c + failIfCycle qpn rdm x = + case findCycles qpn rdm of + Nothing -> x + Just relSet -> Fail relSet CyclicDependencies + +-- | Given the reverse dependency map from a node in the tree, check +-- if the solution is cyclic. If it is, return the conflict set containing +-- all decisions that could potentially break the cycle. +-- +-- TODO: The conflict set should also contain flag and stanza variables. +findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles pkg rdm = + -- This function has two parts: a faster cycle check that is called at every + -- step and a slower calculation of the conflict set. + -- + -- 'hasCycle' checks for cycles incrementally by only looking for cycles + -- containing the current package, 'pkg'. It searches for cycles in the + -- 'RevDepMap', which is the data structure used to store reverse + -- dependencies in the search tree. We store the reverse dependencies in a + -- map, because Data.Map is smaller and/or has better sharing than + -- Distribution.Compat.Graph. + -- + -- If there is a cycle, we call G.cycles to find a strongly connected + -- component. Then we choose one cycle from the component to use for the + -- conflict set. Choosing only one cycle can lead to a smaller conflict set, + -- such as when a choice to enable testing introduces many cycles at once. + -- In that case, all cycles contain the current package and are in one large + -- strongly connected component. + -- + if hasCycle + then let scc :: G.Graph RevDepMapNode + scc = case G.cycles $ revDepMapToGraph rdm of + [] -> findCyclesError "cannot find a strongly connected component" + c : _ -> G.fromDistinctList c + + next :: QPN -> QPN + next p = case G.neighbors scc p of + Just (n : _) -> G.nodeKey n + _ -> findCyclesError "cannot find next node in the cycle" + + -- This function also assumes that all cycles contain 'pkg'. + oneCycle :: [QPN] + oneCycle = case iterate next pkg of + [] -> findCyclesError "empty cycle" + x : xs -> x : takeWhile (/= x) xs + in Just $ CS.fromList $ map P oneCycle + else Nothing + where + hasCycle :: Bool + hasCycle = pkg `S.member` closure (neighbors pkg) + + closure :: [QPN] -> S.Set QPN + closure = foldl go S.empty + where + go :: S.Set QPN -> QPN -> S.Set QPN + go s x = + if x `S.member` s + then s + else foldl go (S.insert x s) $ neighbors x + + neighbors :: QPN -> [QPN] + neighbors x = case x `M.lookup` rdm of + Nothing -> findCyclesError "cannot find node" + Just xs -> map snd xs + + findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) + +data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] + +instance G.IsNode RevDepMapNode where + type Key RevDepMapNode = QPN + nodeKey (RevDepMapNode qpn _) = qpn + nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns + +revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph rdm = G.fromDistinctList + [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Dependency.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif +module Distribution.Solver.Modular.Dependency ( + -- * Variables + Var(..) + , simplifyVar + , varPI + , showVar + -- * Conflict sets + , ConflictSet + , ConflictMap + , CS.showConflictSet + -- * Constrained instances + , CI(..) + , merge + -- * Flagged dependencies + , FlaggedDeps + , FlaggedDep(..) + , Dep(..) + , showDep + , flattenFlaggedDeps + , QualifyOptions(..) + , qualifyDeps + , unqualifyDeps + -- ** Setting/forgetting components + , forgetCompOpenGoal + , setCompFlaggedDeps + -- * Reverse dependency map + , RevDepMap + -- * Goals + , Goal(..) + , GoalReason(..) + , QGoalReason + , ResetVar(..) + , goalToVar + , goalVarToConflictSet + , varToConflictSet + , goalReasonToVars + -- * Open goals + , OpenGoal(..) + , close + ) where + +import Prelude hiding (pi) + +import Data.Map (Map) +import qualified Data.List as L + +import Language.Haskell.Extension (Extension(..), Language(..)) + +import Distribution.Text + +import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS + +import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.PackagePath + +#ifdef DEBUG_CONFLICT_SETS +import GHC.Stack (CallStack) +#endif + +{------------------------------------------------------------------------------- + Constrained instances +-------------------------------------------------------------------------------} + +-- | Constrained instance. If the choice has already been made, this is +-- a fixed instance, and we record the package name for which the choice +-- is for convenience. Otherwise, it is a list of version ranges paired with +-- the goals / variables that introduced them. +data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn] + deriving (Eq, Show, Functor) + +showCI :: CI QPN -> String +showCI (Fixed i _) = "==" ++ showI i +showCI (Constrained vr) = showVR (collapse vr) + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + CI QPN -> CI QPN -> Either (ConflictSet, (CI QPN, CI QPN)) (CI QPN) +merge c@(Fixed i g1) d@(Fixed j g2) + | i == j = Right c + | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d)) +merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... + where + go [] = Right c + go (d@(vr, g2) : vrs) + | checkVR vr v = go vrs + | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d])) +merge c@(Constrained _) d@(Fixed _ _) = merge d c +merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) + +{------------------------------------------------------------------------------- + Flagged dependencies +-------------------------------------------------------------------------------} + +-- | Flagged dependencies +-- +-- 'FlaggedDeps' is the modular solver's view of a packages dependencies: +-- rather than having the dependencies indexed by component, each dependency +-- defines what component it is in. +-- +-- However, top-level goals are also modelled as dependencies, but of course +-- these don't actually belong in any component of any package. Therefore, we +-- parameterize 'FlaggedDeps' and derived datatypes with a type argument that +-- specifies whether or not we have a component: we only ever instantiate this +-- type argument with @()@ for top-level goals, or 'Component' for everything +-- else (we could express this as a kind at the type-level, but that would +-- require a very recent GHC). +-- +-- Note however, crucially, that independent of the type parameters, the list +-- of dependencies underneath a flag choice or stanza choices _always_ uses +-- Component as the type argument. This is important: when we pick a value for +-- a flag, we _must_ know what component the new dependencies belong to, or +-- else we don't be able to construct fine-grained reverse dependencies. +type FlaggedDeps comp qpn = [FlaggedDep comp qpn] + +-- | Flagged dependencies can either be plain dependency constraints, +-- or flag-dependent dependency trees. +data FlaggedDep comp qpn = + -- | Dependencies which are conditional on a flag choice. + Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) + -- | Dependencies which are conditional on whether or not a stanza + -- (e.g., a test suite or benchmark) is enabled. + | Stanza (SN qpn) (TrueFlaggedDeps qpn) + -- | Dependencies for which are always enabled, for the component + -- 'comp' (or requested for the user, if comp is @()@). + | Simple (Dep qpn) comp + deriving (Eq, Show) + +-- | Conversatively flatten out flagged dependencies +-- +-- NOTE: We do not filter out duplicates. +flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)] +flattenFlaggedDeps = concatMap aux + where + aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)] + aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f + aux (Stanza _ t) = flattenFlaggedDeps t + aux (Simple d c) = [(d, c)] + +type TrueFlaggedDeps qpn = FlaggedDeps Component qpn +type FalseFlaggedDeps qpn = FlaggedDeps Component qpn + +-- | Is this dependency on an executable +type IsExe = Bool + +-- | A dependency (constraint) associates a package name with a +-- constrained instance. +-- +-- 'Dep' intentionally has no 'Functor' instance because the type variable +-- is used both to record the dependencies as well as who's doing the +-- depending; having a 'Functor' instance makes bugs where we don't distinguish +-- these two far too likely. (By rights 'Dep' ought to have two type variables.) +data Dep qpn = Dep IsExe qpn (CI qpn) -- ^ dependency on a package (possibly for executable + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package + deriving (Eq, Show) + +showDep :: Dep QPN -> String +showDep (Dep is_exe qpn (Fixed i v) ) = + (if P qpn /= v then showVar v ++ " => " else "") ++ + showQPN qpn ++ + (if is_exe then " (exe) " else "") ++ "==" ++ showI i +showDep (Dep is_exe qpn (Constrained [(vr, v)])) = + showVar v ++ " => " ++ showQPN qpn ++ + (if is_exe then " (exe) " else "") ++ showVR vr +showDep (Dep is_exe qpn ci ) = + showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci +showDep (Ext ext) = "requires " ++ display ext +showDep (Lang lang) = "requires " ++ display lang +showDep (Pkg pn vr) = "requires pkg-config package " + ++ display pn ++ display vr + ++ ", not found in the pkg-config database" + +-- | Options for goal qualification (used in 'qualifyDeps') +-- +-- See also 'defaultQualifyOptions' +data QualifyOptions = QO { + -- | Do we have a version of base relying on another version of base? + qoBaseShim :: Bool + + -- Should dependencies of the setup script be treated as independent? + , qoSetupIndependent :: Bool + } + deriving Show + +-- | Apply built-in rules for package qualifiers +-- +-- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', +-- it is important that these 'QualifyOptions' are _static_. Qualification +-- does NOT depend on flag assignment; in other words, it behaves the same no +-- matter which choices the solver makes (modulo the global 'QualifyOptions'); +-- we rely on this in 'linkDeps' (see comment there). +-- +-- NOTE: It's the _dependencies_ of a package that may or may not be independent +-- from the package itself. Package flag choices must of course be consistent. +qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN +qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go + where + go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN + go = map go1 + + go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN + go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) + go1 (Simple dep comp) = Simple (goD dep comp) comp + + -- Suppose package B has a setup dependency on package A. + -- This will be recorded as something like + -- + -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason]) + -- + -- Observe that when we qualify this dependency, we need to turn that + -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier + -- to the goal or the goal reason chain. + goD :: Dep PN -> Component -> Dep QPN + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr + goD (Dep is_exe dep ci) comp + | is_exe = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) (fmap (Q pp) ci) + | qBase dep = Dep is_exe (Q (PackagePath ns (QualBase pn)) dep) (fmap (Q pp) ci) + | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) (fmap (Q pp) ci) + | otherwise = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci) + + -- If P has a setup dependency on Q, and Q has a regular dependency on R, then + -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup + -- dependency on R. We do not do this for the base qualifier however. + -- + -- The inherited qualifier is only used for regular dependencies; for setup + -- and base deppendencies we override the existing qualifier. See #3160 for + -- a detailed discussion. + inheritedQ :: Qualifier + inheritedQ = case q of + QualSetup _ -> q + QualExe _ _ -> q + QualToplevel -> q + QualBase _ -> QualToplevel + + -- Should we qualify this goal with the 'Base' package path? + qBase :: PN -> Bool + qBase dep = qoBaseShim && unPackageName dep == "base" + + -- Should we qualify this goal with the 'Setup' package path? + qSetup :: Component -> Bool + qSetup comp = qoSetupIndependent && comp == ComponentSetup + +-- | Remove qualifiers from set of dependencies +-- +-- This is used during link validation: when we link package @Q.A@ to @Q'.A@, +-- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute +-- what to link these dependencies to, we need to requalify @Q.B@ to become +-- @Q'.B@; we do this by first removing all qualifiers and then calling +-- 'qualifyDeps' again. +unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN +unqualifyDeps = go + where + go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN + go = map go1 + + go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN + go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) + go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) + go1 (Simple dep comp) = Simple (goD dep) comp + + goD :: Dep QPN -> Dep PN + goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci) + goD (Ext ext) = Ext ext + goD (Lang lang) = Lang lang + goD (Pkg pn vr) = Pkg pn vr + + unq :: QPN -> PN + unq (Q _ pn) = pn + +{------------------------------------------------------------------------------- + Setting/forgetting the Component +-------------------------------------------------------------------------------} + +forgetCompOpenGoal :: OpenGoal Component -> OpenGoal () +forgetCompOpenGoal = mapCompOpenGoal $ const () + +setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn +setCompFlaggedDeps = mapCompFlaggedDeps . const + +{------------------------------------------------------------------------------- + Auxiliary: Mapping over the Component goal + + We don't export these, because the only type instantiations for 'a' and 'b' + here should be () or Component. (We could express this at the type level + if we relied on newer versions of GHC.) +-------------------------------------------------------------------------------} + +mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b +mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr + +mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn +mapCompFlaggedDeps = L.map . mapCompFlaggedDep + +mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn +mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo t f +mapCompFlaggedDep _ (Stanza sn t ) = Stanza sn t +mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a) + +{------------------------------------------------------------------------------- + Reverse dependency map +-------------------------------------------------------------------------------} + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [(Component, QPN)] + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | A goal is just a solver variable paired with a reason. +-- The reason is only used for tracing. +data Goal qpn = Goal (Var qpn) (GoalReason qpn) + deriving (Eq, Show, Functor) + +-- | Reason why a goal is being added to a goal set. +data GoalReason qpn = + UserGoal + | PDependency (PI qpn) + | FDependency (FN qpn) Bool + | SDependency (SN qpn) + deriving (Eq, Show, Functor) + +type QGoalReason = GoalReason QPN + +class ResetVar f where + resetVar :: Var qpn -> f qpn -> f qpn + +instance ResetVar CI where + resetVar v (Fixed i _) = Fixed i v + resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs) + +instance ResetVar Dep where + resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci) + resetVar _ (Ext ext) = Ext ext + resetVar _ (Lang lang) = Lang lang + resetVar _ (Pkg pn vr) = Pkg pn vr + +instance ResetVar Var where + resetVar = const + +goalToVar :: Goal a -> Var a +goalToVar (Goal v _) = v + +-- | Compute a singleton conflict set from a goal, containing just +-- the goal variable. +-- +-- NOTE: This is just a call to 'varToConflictSet' under the hood; +-- the 'GoalReason' is ignored. +goalVarToConflictSet :: Goal QPN -> ConflictSet +goalVarToConflictSet (Goal g _gr) = varToConflictSet g + +-- | Compute a singleton conflict set from a 'Var' +varToConflictSet :: Var QPN -> ConflictSet +varToConflictSet = CS.singleton + +-- | A goal reason is mostly just a variable paired with the +-- decision we made for that variable (except for user goals, +-- where we cannot really point to a solver variable). This +-- function drops the decision and recovers the list of +-- variables (which will be empty or contain one element). +-- +goalReasonToVars :: GoalReason qpn -> [Var qpn] +goalReasonToVars UserGoal = [] +goalReasonToVars (PDependency (PI qpn _)) = [P qpn] +goalReasonToVars (FDependency qfn _) = [F qfn] +goalReasonToVars (SDependency qsn) = [S qsn] + +{------------------------------------------------------------------------------- + Open goals +-------------------------------------------------------------------------------} + +-- | For open goals as they occur during the build phase, we need to store +-- additional information about flags. +data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason + deriving (Eq, Show) + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal comp -> Goal QPN +close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr +close (OpenGoal (Simple (Ext _) _) _ ) = + error "Distribution.Solver.Modular.Dependency.close: called on Ext goal" +close (OpenGoal (Simple (Lang _) _) _ ) = + error "Distribution.Solver.Modular.Dependency.close: called on Lang goal" +close (OpenGoal (Simple (Pkg _ _) _) _ ) = + error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal" +close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr +close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr + +{------------------------------------------------------------------------------- + Version ranges paired with origins +-------------------------------------------------------------------------------} + +type VROrigin qpn = (VR, Var qpn) + +-- | Helper function to collapse a list of version ranges with origins into +-- a single, simplified, version range. +collapse :: [VROrigin qpn] -> VR +collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Explore.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Explore + ( backjump + , backjumpAndExplore + ) where + +import Data.Foldable as F +import Data.List as L (foldl') +import Data.Map as M + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import qualified Distribution.Solver.Modular.PSQ as P +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) + +-- | This function takes the variable we're currently considering, an +-- initial conflict set and a +-- list of children's logs. Each log yields either a solution or a +-- conflict set. The result is a combined log for the parent node that +-- has explored a prefix of the children. +-- +-- We can stop traversing the children's logs if we find an individual +-- conflict set that does not contain the current variable. In this +-- case, we can just lift the conflict set to the current level, +-- because the current level cannot possibly have contributed to this +-- conflict, so no other choice at the current level would avoid the +-- conflict. +-- +-- If any of the children might contain a successful solution, we can +-- return it immediately. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +-- +-- The initial conflict set corresponds to the justification that we +-- have to choose this goal at all. There is a reason why we have +-- introduced the goal in the first place, and this reason is in conflict +-- with the (virtual) option not to choose anything for the current +-- variable. See also the comments for 'avoidSet'. +-- +backjump :: EnableBackjumping -> Var QPN + -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a) + -> ConflictMap -> ConflictSetLog a +backjump (EnableBackjumping enableBj) var initial xs = + F.foldr combine logBackjump xs initial + where + combine :: forall a . (ConflictMap -> ConflictSetLog a) + -> (ConflictSet -> ConflictMap -> ConflictSetLog a) + -> ConflictSet -> ConflictMap -> ConflictSetLog a + combine x f csAcc cm = retry (x cm) next + where + next :: (ConflictSet, ConflictMap) -> ConflictSetLog a + next (cs, cm') + | enableBj && not (var `CS.member` cs) = logBackjump cs cm' + | otherwise = f (csAcc `CS.union` cs) cm' + + logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a + logBackjump cs !cm = failWith (Failure cs Backjump) (cs, updateCM initial cm) + -- 'intial' instead of 'cs' here ---^ + -- since we do not want to double-count the + -- additionally accumulated conflicts. + +type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap) + +getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) +getBestGoal cm = + P.maximumBy + ( flip (M.findWithDefault 0) cm + . (\ (Goal v _) -> v) + ) + +getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) +getFirstGoal ts = + P.casePSQ ts + (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error + (\ k v _xs -> (k, v)) -- commit to the first goal choice + +updateCM :: ConflictSet -> ConflictMap -> ConflictMap +updateCM cs cm = + L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs) + where + inc Nothing = Just 1 + inc (Just n) = Just $! n + 1 + +-- | Record complete assignments on 'Done' nodes. +assign :: Tree d c -> Tree Assignment c +assign tree = cata go tree $ A M.empty M.empty M.empty + where + go :: TreeF d c (Assignment -> Tree Assignment c) + -> (Assignment -> Tree Assignment c) + go (FailF c fr) _ = Fail c fr + go (DoneF rdm _) a = Done rdm a + go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts + where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) + go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts + where f k r = r (A pa (M.insert qfn k fa) sa) + go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts + where f k r = r (A pa fa (M.insert qsn k sa)) + go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts + +-- | A tree traversal that simultaneously propagates conflict sets up +-- the tree from the leaves and creates a log. +exploreLog :: EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason + -> ConflictSetLog (Assignment, RevDepMap) +exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty + where + getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) + getBestGoal' + | countConflicts = \ ts cm -> getBestGoal cm ts + | otherwise = \ ts _ -> getFirstGoal ts + + go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) + -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) + go (FailF c fr) = \ !cm -> failWith (Failure c fr) + (c, updateCM c cm) + go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) + go (PChoiceF qpn _ gr ts) = + backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r cm -> tryWith (TryP qpn k) (r cm)) + ts + go (FChoiceF qfn _ gr _ _ _ ts) = + backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r cm -> tryWith (TryF qfn k) (r cm)) + ts + go (SChoiceF qsn _ gr _ ts) = + backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r cm -> tryWith (TryS qsn k) (r cm)) + ts + go (GoalChoiceF _ ts) = \ cm -> + let (k, v) = getBestGoal' ts cm + in continueWith (Next k) (v cm) + +-- | Build a conflict set corresponding to the (virtual) option not to +-- choose a solution for a goal at all. +-- +-- In the solver, the set of goals is not statically determined, but depends +-- on the choices we make. Therefore, when dealing with conflict sets, we +-- always have to consider that we could perhaps make choices that would +-- avoid the existence of the goal completely. +-- +-- Whenever we actual introduce a choice in the tree, we have already established +-- that the goal cannot be avoided. This is tracked in the "goal reason". +-- The choice to avoid the goal therefore is a conflict between the goal itself +-- and its goal reason. We build this set here, and pass it to the 'backjump' +-- function as the initial conflict set. +-- +-- This has two effects: +-- +-- - In a situation where there are no choices available at all (this happens +-- if an unknown package is requested), the initial conflict set becomes the +-- actual conflict set. +-- +-- - In a situation where all of the children's conflict sets contain the +-- current variable, the goal reason of the current node will be added to the +-- conflict set. +-- +avoidSet :: Var QPN -> QGoalReason -> ConflictSet +avoidSet var gr = + CS.fromList (var : goalReasonToVars gr) + +-- | Interface. +backjumpAndExplore :: EnableBackjumping + -> CountConflicts + -> Tree d QGoalReason -> Log Message (Assignment, RevDepMap) +backjumpAndExplore enableBj countConflicts = + toProgress . exploreLog enableBj countConflicts . assign diff --git a/Distribution/Solver/Modular/Flag.hs b/Distribution/Solver/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Flag.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Flag + ( FInfo(..) + , Flag + , FlagInfo + , FN(..) + , QFN + , QSN + , SN(..) + , WeakOrTrivial(..) + , mkFlag + , showFBool + , showQFN + , showQFNBool + , showQSN + , showQSNBool + ) where + +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.PackageDescription hiding (Flag) -- from Cabal + +import Distribution.Solver.Modular.Package +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN (PI qpn) Flag + deriving (Eq, Ord, Show, Functor) + +-- | Flag identifier. Just a string. +type Flag = FlagName + +unFlag :: Flag -> String +unFlag = unFlagName + +mkFlag :: String -> Flag +mkFlag = mkFlagName + +-- | Flag info. Default value, whether the flag is manual, and +-- whether the flag is weak. Manual flags can only be set explicitly. +-- Weak flags are typically deferred by the solver. +data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } + deriving (Eq, Show) + +-- | Flag defaults. +type FlagInfo = Map Flag FInfo + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN (PI qpn) OptionalStanza + deriving (Eq, Ord, Show, Functor) + +-- | Qualified stanza name. +type QSN = SN QPN + +-- | A property of flag and stanza choices that determines whether the +-- choice should be deferred in the solving process. +-- +-- A choice is called weak if we do want to defer it. This is the +-- case for flags that should be implied by what's currently installed on +-- the system, as opposed to flags that are used to explicitly enable or +-- disable some functionality. +-- +-- A choice is called trivial if it clearly does not matter. The +-- special case of triviality we actually consider is if there are no new +-- dependencies introduced by the choice. +newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } + deriving (Eq, Ord, Show) + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) v = showFlagValue (f, v) + +showSBool :: SN qpn -> Bool -> String +showSBool (SN _ s) True = "*" ++ showStanza s +showSBool (SN _ s) False = "!" ++ showStanza s + +showQFN :: QFN -> String +showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN pi s) = showPI pi ++ ":" ++ showStanza s diff --git a/Distribution/Solver/Modular/Index.hs b/Distribution/Solver/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Index.hs @@ -0,0 +1,52 @@ +module Distribution.Solver.Modular.Index + ( Index + , PInfo(..) + , defaultQualifyOptions + , mkIndex + ) where + +import Data.List as L +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + +import Distribution.Solver.Types.ComponentDeps (Component) + +-- | An index contains information about package instances. This is a nested +-- dictionary. Package names are mapped to instances, which in turn is mapped +-- to info. +type Index = Map PN (Map I PInfo) + +-- | Info associated with a package instance. +-- Currently, dependencies, flags and failure reasons. +-- Packages that have a failure reason recorded for them are disabled +-- globally, for reasons external to the solver. We currently use this +-- for shadowing which essentially is a GHC limitation, and for +-- installed packages that are broken. +data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason) + deriving (Show) + +mkIndex :: [(PN, I, PInfo)] -> Index +mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) + +groupMap :: Ord a => [(a, b)] -> Map a [b] +groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) + +defaultQualifyOptions :: Index -> QualifyOptions +defaultQualifyOptions idx = QO { + qoBaseShim = or [ dep == base + | -- Find all versions of base .. + Just is <- [M.lookup base idx] + -- .. which are installed .. + , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is + -- .. and flatten all their dependencies .. + , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps + ] + , qoSetupIndependent = True + } + where + base = mkPackageName "base" diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/IndexConversion.hs @@ -0,0 +1,350 @@ +module Distribution.Solver.Modular.IndexConversion + ( convPIs + ) where + +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Monoid as Mon +import Data.Set as S +import Prelude hiding (pi) + +import Distribution.Compiler +import Distribution.InstalledPackageInfo as IPI +import Distribution.Package -- from Cabal +import Distribution.Simple.BuildToolDepends -- from Cabal +import Distribution.Types.ExeDependency -- from Cabal +import Distribution.Types.PkgconfigDependency -- from Cabal +import Distribution.Types.ComponentName -- from Cabal +import Distribution.Types.UnqualComponentName -- from Cabal +import Distribution.Types.CondTree -- from Cabal +import Distribution.Types.MungedPackageId -- from Cabal +import Distribution.Types.MungedPackageName -- from Cabal +import Distribution.PackageDescription as PD -- from Cabal +import Distribution.PackageDescription.Configuration as PDC +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System +import Distribution.Types.ForeignLib + +import Distribution.Solver.Types.ComponentDeps + ( Component(..), componentNameToComponent ) +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as CI +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SourcePackage + +import Distribution.Solver.Modular.Dependency as D +import Distribution.Solver.Modular.Flag as F +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesBySourcePackageId' for the installed package index +-- because that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to \"shadow\" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- resolving these situations. However, the right thing to do is to +-- fix the problem there, so for now, shadowing is only activated if +-- explicitly requested. +convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables -> + SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index +convPIs os arch comp sip strfl sexes iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes sidx) + +-- | Convert a Cabal installed package index to the simpler, +-- more uniform index format of the solver. +convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] +convIPI' (ShadowPkgs sip) idx = + -- apply shadowing whenever there are multiple installed packages with + -- the same version + [ maybeShadow (convIP idx pkg) + -- IMPORTANT to get internal libraries. See + -- Note [Index conversion with internal libraries] + | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] + where + + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) + shadow x = x + +-- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. +convId :: InstalledPackageInfo -> (PN, I) +convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) + where MungedPackageId mpn ver = mungedId ipi + -- HACK. See Note [Index conversion with internal libraries] + pn = mkPackageName (unMungedPackageName mpn) + +-- | Convert a single installed package into the solver-specific format. +convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) +convIP idx ipi = + case mapM (convIPId pn idx) (IPI.depends ipi) of + Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) + Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing) + where + (pn, i) = convId ipi + -- 'sourceLibName' is unreliable, but for now we only really use this for + -- primary libs anyways + setComp = setCompFlaggedDeps $ componentNameToComponent + $ libraryComponentName $ sourceLibName ipi +-- TODO: Installed packages should also store their encapsulations! + +-- Note [Index conversion with internal libraries] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Something very interesting happens when we have internal libraries +-- in our index. In this case, we maybe have p-0.1, which itself +-- depends on the internal library p-internal ALSO from p-0.1. +-- Here's the danger: +-- +-- - If we treat both of these packages as having PN "p", +-- then the solver will try to pick one or the other, +-- but never both. +-- +-- - If we drop the internal packages, now p-0.1 has a +-- dangling dependency on an "installed" package we know +-- nothing about. Oops. +-- +-- An expedient hack is to put p-internal into cabal-install's +-- index as a MUNGED package name, so that it doesn't conflict +-- with anyone else (except other instances of itself). But +-- yet, we ought NOT to say that PNs in the solver are munged +-- package names, because they're not; for source packages, +-- we really will never see munged package names. +-- +-- The tension here is that the installed package index is actually +-- per library, but the solver is per package. We need to smooth +-- it over, and munging the package names is a pretty good way to +-- do it. + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- May return Nothing if the package can't be found in the index. That +-- indicates that the original package having this dependency is broken +-- and should be ignored. +convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) +convIPId pn' idx ipid = + case SI.lookupUnitId idx ipid of + Nothing -> Nothing + Just ipi -> let (pn, i) = convId ipi + in Just (D.Simple (Dep False pn (Fixed i (P pn'))) ()) + -- NB: something we pick up from the + -- InstalledPackageIndex is NEVER an executable + +-- | Convert a cabal-install source package index to the simpler, +-- more uniform index format of the solver. +convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> + CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] +convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages + +-- | Convert a single source package into the solver-specific format. +convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) +convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = + let i = I pv InRepo + in (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) gpd) + +-- We do not use 'flattenPackageDescription' or 'finalizePD' +-- from 'Distribution.PackageDescription.Configuration' here, because we +-- want to keep the condition tree, but simplify much of the test. + +-- | Convert a generic package description to a solver-specific 'PInfo'. +convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> + PI PN -> GenericPackageDescription -> PInfo +convGPD os arch cinfo strfl sexes pi + (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) = + let + fds = flagInfo strfl flags + + -- | We have to be careful to filter out dependencies on + -- internal libraries, since they don't refer to real packages + -- and thus cannot actually be solved over. We'll do this + -- by creating a set of package names which are "internal" + -- and dropping them as we convert. + + ipns = S.fromList $ [ unqualComponentNameToPackageName nm + | (nm, _) <- sub_libs ] + + conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> + CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN + conv comp getInfo = convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes . + PDC.addBuildableCondition getInfo + + flagged_deps + = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo ds) exes + ++ prefix (Stanza (SN pi TestStanzas)) + (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo ds) tests) + ++ prefix (Stanza (SN pi BenchStanzas)) + (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs) + ++ maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg) + + in + PInfo flagged_deps fds Nothing + +-- | Create a flagged dependency tree from a list @fds@ of flagged +-- dependencies, using @f@ to form the tree node (@f@ will be +-- something like @Stanza sn@). +prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) + -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn +prefix _ [] = [] +prefix f fds = [f (concat fds)] + +-- | Convert flag information. Automatic flags are now considered weak +-- unless strong flags have been selected explicitly. +flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo +flagInfo (StrongFlags strfl) = + M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) + where + weak m = WeakOrTrivial $ not (strfl || m) + flagType m = if m then Manual else Automatic + +-- | Internal package names, which should not be interpreted as true +-- dependencies. +type IPNs = Set PN + +-- | Convenience function to delete a 'FlaggedDep' if it's +-- for a 'PN' that isn't actually real. +filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN +filterIPNs ipns (Dependency pn _) fd + | S.notMember pn ipns = [fd] + | otherwise = [] + +-- | Convert condition trees to flagged dependencies. Mutually +-- recursive with 'convBranch'. See 'convBranch' for an explanation +-- of all arguments preceeding the input 'CondTree'. +convCondTree :: PackageDescription -> OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> + Component -> + (a -> BuildInfo) -> + IPNs -> + SolveExecutables -> + CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN +convCondTree pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) = + concatMap + (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp)) + ds -- unconditional package dependencies + ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch pkg os arch cinfo pi fds comp getInfo ipns sexes) branches + -- build-tools dependencies + -- NB: Only include these dependencies if SolveExecutables + -- is True. It might be false in the legacy solver + -- codepath, in which case there won't be any record of + -- an executable we need. + ++ [ D.Simple (convExeDep pn exeDep) comp + | sexes' + , exeDep <- getAllToolDependencies pkg bi + , not $ isInternal pkg exeDep + ] + where + bi = getInfo info + +-- | Branch interpreter. Mutually recursive with 'convCondTree'. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +-- +-- This function takes a number of arguments: +-- +-- 1. Some pre dependency-solving known information ('OS', 'Arch', +-- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, +-- +-- 2. The package instance @'PI' 'PN'@ which this condition tree +-- came from, so that we can correctly associate @flag()@ +-- variables with the correct package name qualifier, +-- +-- 3. The flag defaults 'FlagInfo' so that we can populate +-- 'Flagged' dependencies with 'FInfo', +-- +-- 4. The name of the component 'Component' so we can record where +-- the fine-grained information about where the component came +-- from (see 'convCondTree'), and +-- +-- 5. A selector to extract the 'BuildInfo' from the leaves of +-- the 'CondTree' (which actually contains the needed +-- dependency information.) +-- +-- 6. The set of package names which should be considered internal +-- dependencies, and thus not handled as dependencies. +convBranch :: PackageDescription -> OS -> Arch -> CompilerInfo -> + PI PN -> FlagInfo -> + Component -> + (a -> BuildInfo) -> + IPNs -> + SolveExecutables -> + CondBranch ConfVar [Dependency] a -> + FlaggedDeps Component PN +convBranch pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (CondBranch c' t' mf') = + go c' ( convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes t') + (maybe [] (convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes) mf') + where + go :: Condition ConfVar -> + FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN + go (Lit True) t _ = t + go (Lit False) _ f = f + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) + go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (OS os')) t f + | os == os' = t + | otherwise = f + go (Var (Arch arch')) t f + | arch == arch' = t + | otherwise = f + go (Var (Impl cf cvr)) t f + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t + | otherwise = f + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + + -- If both branches contain the same package as a simple dep, we lift it to + -- the next higher-level, but without constraints. This heuristic together + -- with deferring flag choices will then usually first resolve this package, + -- and try an already installed version before imposing a default flag choice + -- that might not be what we want. + -- + -- Note that we make assumptions here on the form of the dependencies that + -- can occur at this point. In particular, no occurrences of Fixed, and no + -- occurrences of multiple version ranges, as all dependencies below this + -- point have been generated using 'convLibDep'. + -- + -- WARNING: This is quadratic! + extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN + extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp + | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps + , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps' + , pn1 == pn2 + , is_exe1 == is_exe2 + ] + +-- | Convert a Cabal dependency on a library to a solver-specific dependency. +convLibDep :: PN -> Dependency -> Dep PN +convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')]) + +-- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency. +-- TODO do something about the name of the exe component itself +convExeDep :: PN -> ExeDependency -> Dep PN +convExeDep pn' (ExeDependency pn _ vr) = Dep True pn (Constrained [(vr, P pn')]) + +-- | Convert setup dependencies +convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN +convSetupBuildInfo (PI pn _i) nfo = + L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo) diff --git a/Distribution/Solver/Modular/LabeledGraph.hs b/Distribution/Solver/Modular/LabeledGraph.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/LabeledGraph.hs @@ -0,0 +1,116 @@ +-- | Wrapper around Data.Graph with support for edge labels +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.LabeledGraph ( + -- * Graphs + Graph + , Vertex + -- ** Building graphs + , graphFromEdges + , graphFromEdges' + , buildG + , transposeG + -- ** Graph properties + , vertices + , edges + -- ** Operations on the underlying unlabeled graph + , forgetLabels + , topSort + ) where + +import Data.Array +import Data.Graph (Vertex, Bounds) +import Data.List (sortBy) +import Data.Maybe (mapMaybe) +import qualified Data.Graph as G + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +type Graph e = Array Vertex [(e, Vertex)] +type Edge e = (Vertex, e, Vertex) + +{------------------------------------------------------------------------------- + Building graphs +-------------------------------------------------------------------------------} + +-- | Construct an edge-labeled graph +-- +-- This is a simple adaptation of the definition in Data.Graph +graphFromEdges :: forall key node edge. Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + , key -> Maybe Vertex + ) +graphFromEdges edges0 = + (graph, \v -> vertex_map ! v, key_vertex) + where + max_v = length edges0 - 1 + bounds0 = (0, max_v) :: (Vertex, Vertex) + sorted_edges = sortBy lt edges0 + edges1 = zipWith (,) [0..] sorted_edges + + graph = array bounds0 [(v, (mapMaybe mk_edge ks)) + | (v, (_, _, ks)) <- edges1] + key_map = array bounds0 [(v, k ) + | (v, (_, k, _ )) <- edges1] + vertex_map = array bounds0 edges1 + + (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + + mk_edge :: (edge, key) -> Maybe (edge, Vertex) + mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) + + -- returns Nothing for non-interesting vertices + key_vertex :: key -> Maybe Vertex + key_vertex k = findVertex 0 max_v + where + findVertex a b + | a > b = Nothing + | otherwise = case compare k (key_map ! mid) of + LT -> findVertex a (mid-1) + EQ -> Just mid + GT -> findVertex (mid+1) b + where + mid = a + (b - a) `div` 2 + +graphFromEdges' :: Ord key + => [ (node, key, [(edge, key)]) ] + -> ( Graph edge + , Vertex -> (node, key, [(edge, key)]) + ) +graphFromEdges' x = (a,b) + where + (a,b,_) = graphFromEdges x + +transposeG :: Graph e -> Graph e +transposeG g = buildG (bounds g) (reverseE g) + +buildG :: Bounds -> [Edge e] -> Graph e +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where + reassoc (v, e, w) = (v, (e, w)) + +reverseE :: Graph e -> [Edge e] +reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] + +{------------------------------------------------------------------------------- + Graph properties +-------------------------------------------------------------------------------} + +vertices :: Graph e -> [Vertex] +vertices = indices + +edges :: Graph e -> [Edge e] +edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] + +{------------------------------------------------------------------------------- + Operations on the underlying unlabelled graph +-------------------------------------------------------------------------------} + +forgetLabels :: Graph e -> G.Graph +forgetLabels = fmap (map snd) + +topSort :: Graph e -> [Vertex] +topSort = G.topSort . forgetLabels diff --git a/Distribution/Solver/Modular/Linking.hs b/Distribution/Solver/Modular/Linking.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Linking.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Distribution.Solver.Modular.Linking ( + validateLinking + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get,put) + +import Control.Exception (assert) +import Control.Monad.Reader +import Control.Monad.State +import Data.Map ((!)) +import Data.Set (Set) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Traversable as T + +import Distribution.Client.Utils.Assertion +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Types.GenericPackageDescription (unFlagName) + +{------------------------------------------------------------------------------- + Validation + + Validation of links is a separate pass that's performed after normal + validation. Validation of links checks that if the tree indicates that a + package is linked, then everything underneath that choice really matches the + package we have linked to. + + This is interesting because it isn't unidirectional. Consider that we've + chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. + Now foo depends on bar. Because a.foo and b.foo are linked, it's required that + a.bar and b.bar are also linked. However, it's not required that we actually + choose a.bar before b.bar. Goal choice order is relatively free. It's possible + that we choose a.bar first, but also possible that we choose b.bar first. In + both cases, we have to recognize that we have freedom of choice for the first + of the two, but no freedom of choice for the second. + + This is what LinkGroups are all about. Using LinkGroup, we can record (in the + situation above) that a.bar and b.bar need to be linked even if we haven't + chosen either of them yet. +-------------------------------------------------------------------------------} + +data ValidateState = VS { + vsIndex :: Index + , vsLinks :: Map QPN LinkGroup + , vsFlags :: FAssignment + , vsStanzas :: SAssignment + , vsQualifyOptions :: QualifyOptions + } + deriving Show + +type Validate = Reader ValidateState + +-- | Validate linked packages +-- +-- Verify that linked packages have +-- +-- * Linked dependencies, +-- * Equal flag assignments +-- * Equal stanza assignments +validateLinking :: Index -> Tree d c -> Tree d c +validateLinking index = (`runReader` initVS) . cata go + where + go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) + + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs) + go (FChoiceF qfn rdm gr t m d cs) = + FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs) + go (SChoiceF qsn rdm gr t cs) = + SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) + + -- For the other nodes we just recurse + go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs + go (DoneF revDepMap s) = return $ Done revDepMap s + go (FailF conflictSet failReason) = return $ Fail conflictSet failReason + + -- Package choices + goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) + goP qpn@(Q _pp pn) opt@(POption i _) r = do + vs <- ask + let PInfo deps _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + case execUpdateState (pickPOption qpn opt qdeps) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + -- Flag choices + goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goF qfn b r = do + vs <- ask + case execUpdateState (pickFlag qfn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + -- Stanza choices (much the same as flag choices) + goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goS qsn b r = do + vs <- ask + case execUpdateState (pickStanza qsn b) vs of + Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) + Right vs' -> local (const vs') r + + initVS :: ValidateState + initVS = VS { + vsIndex = index + , vsLinks = M.empty + , vsFlags = M.empty + , vsStanzas = M.empty + , vsQualifyOptions = defaultQualifyOptions index + } + +{------------------------------------------------------------------------------- + Updating the validation state +-------------------------------------------------------------------------------} + +type Conflict = (ConflictSet, String) + +newtype UpdateState a = UpdateState { + unUpdateState :: StateT ValidateState (Either Conflict) a + } + deriving (Functor, Applicative, Monad) + +instance MonadState ValidateState UpdateState where + get = UpdateState $ get + put st = UpdateState $ do + expensiveAssert (lgInvariant $ vsLinks st) $ return () + put st + +lift' :: Either Conflict a -> UpdateState a +lift' = UpdateState . lift + +conflict :: Conflict -> UpdateState a +conflict = lift' . Left + +execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState +execUpdateState = execStateT . unUpdateState + +pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState () +pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i +pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps + +pickConcrete :: QPN -> I -> UpdateState () +pickConcrete qpn@(Q pp _) i = do + vs <- get + case M.lookup qpn (vsLinks vs) of + -- Package is not yet in a LinkGroup. Create a new singleton link group. + Nothing -> do + let lg = lgSingleton qpn (Just $ PI pp i) + updateLinkGroup lg + + -- Package is already in a link group. Since we are picking a concrete + -- instance here, it must by definition be the canonical package. + Just lg -> + makeCanonical lg qpn i + +pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState () +pickLink qpn@(Q _pp pn) i pp' deps = do + vs <- get + + -- The package might already be in a link group + -- (because one of its reverse dependencies is) + let lgSource = case M.lookup qpn (vsLinks vs) of + Nothing -> lgSingleton qpn Nothing + Just lg -> lg + + -- Find the link group for the package we are linking to + -- + -- Since the builder never links to a package without having first picked a + -- concrete instance for that package, and since we create singleton link + -- groups for concrete instances, this link group must exist (and must + -- in fact already have a canonical member). + let target = Q pp' pn + lgTarget = vsLinks vs ! target + + -- Verify here that the member we add is in fact for the same package and + -- matches the version of the canonical instance. However, violations of + -- these checks would indicate a bug in the linker, not a true conflict. + let sanityCheck :: Maybe (PI PackagePath) -> Bool + sanityCheck Nothing = False + sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI + assert (sanityCheck (lgCanon lgTarget)) $ return () + + -- Merge the two link groups (updateLinkGroup will propagate the change) + lgTarget' <- lift' $ lgMerge [] lgSource lgTarget + updateLinkGroup lgTarget' + + -- Make sure all dependencies are linked as well + linkDeps target [P qpn] deps + +makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () +makeCanonical lg qpn@(Q pp _) i = + case lgCanon lg of + -- There is already a canonical member. Fail. + Just _ -> + conflict ( CS.insert (P qpn) (lgConflictSet lg) + , "cannot make " ++ showQPN qpn + ++ " canonical member of " ++ showLinkGroup lg + ) + Nothing -> do + let lg' = lg { lgCanon = Just (PI pp i) } + updateLinkGroup lg' + +-- | Link the dependencies of linked parents. +-- +-- When we decide to link one package against another we walk through the +-- package's direct depedencies and make sure that they're all linked to each +-- other by merging their link groups (or creating new singleton link groups if +-- they don't have link groups yet). We do not need to do this recursively, +-- because having the direct dependencies in a link group means that we must +-- have already made or will make sooner or later a link choice for one of these +-- as well, and cover their dependencies at that point. +linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState () +linkDeps target = \blame deps -> do + -- linkDeps is called in two places: when we first link one package to + -- another, and when we discover more dependencies of an already linked + -- package after doing some flag assignment. It is therefore important that + -- flag assignments cannot influence _how_ dependencies are qualified; + -- fortunately this is a documented property of 'qualifyDeps'. + rdeps <- requalify deps + go blame deps rdeps + where + go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState () + go = zipWithM_ . go1 + + go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState () + go1 blame dep rdep = case (dep, rdep) of + (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do + vs <- get + let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs + lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs + lg'' <- lift' $ lgMerge blame lg lg' + updateLinkGroup lg'' + (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do + vs <- get + case M.lookup fn (vsFlags vs) of + Nothing -> return () -- flag assignment not yet known + Just True -> go (F fn:blame) t t' + Just False -> go (F fn:blame) f f' + (Stanza sn t, ~(Stanza _ t')) -> do + vs <- get + case M.lookup sn (vsStanzas vs) of + Nothing -> return () -- stanza assignment not yet known + Just True -> go (S sn:blame) t t' + Just False -> return () -- stanza not enabled; no new deps + -- For extensions and language dependencies, there is nothing to do. + -- No choice is involved, just checking, so there is nothing to link. + -- The same goes for for pkg-config constraints. + (Simple (Ext _) _, _) -> return () + (Simple (Lang _) _, _) -> return () + (Simple (Pkg _ _) _, _) -> return () + + requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN) + requalify deps = do + vs <- get + return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + +pickFlag :: QFN -> Bool -> UpdateState () +pickFlag qfn b = do + modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } + verifyFlag qfn + linkNewDeps (F qfn) b + +pickStanza :: QSN -> Bool -> UpdateState () +pickStanza qsn b = do + modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } + verifyStanza qsn + linkNewDeps (S qsn) b + +-- | Link dependencies that we discover after making a flag choice. +-- +-- When we make a flag choice for a package, then new dependencies for that +-- package might become available. If the package under consideration is in a +-- non-trivial link group, then these new dependencies have to be linked as +-- well. In linkNewDeps, we compute such new dependencies and make sure they are +-- linked. +linkNewDeps :: Var QPN -> Bool -> UpdateState () +linkNewDeps var b = do + vs <- get + let (qpn@(Q pp pn), Just i) = varPI var + PInfo deps _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + lg = vsLinks vs ! qpn + (parents, newDeps) = findNewDeps vs qdeps + linkedTo = S.delete pp (lgMembers lg) + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps + where + findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN) + findNewDeps vs = concatMapUnzip (findNewDeps' vs) + + findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN) + findNewDeps' _ (Simple _ _) = ([], []) + findNewDeps' vs (Flagged qfn _ t f) = + case (F qfn == var, M.lookup qfn (vsFlags vs)) of + (True, _) -> ([F qfn], if b then t else f) + (_, Nothing) -> ([], []) -- not yet known + (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f) + in (F qfn:parents, deps) + findNewDeps' vs (Stanza qsn t) = + case (S qsn == var, M.lookup qsn (vsStanzas vs)) of + (True, _) -> ([S qsn], if b then t else []) + (_, Nothing) -> ([], []) -- not yet known + (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else []) + in (S qsn:parents, deps) + +updateLinkGroup :: LinkGroup -> UpdateState () +updateLinkGroup lg = do + verifyLinkGroup lg + modify $ \vs -> vs { + vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) + `M.union` vsLinks vs + } + where + aux pp = (Q pp (lgPackage lg), lg) + +{------------------------------------------------------------------------------- + Verification +-------------------------------------------------------------------------------} + +verifyLinkGroup :: LinkGroup -> UpdateState () +verifyLinkGroup lg = + case lgInstance lg of + -- No instance picked yet. Nothing to verify + Nothing -> + return () + + -- We picked an instance. Verify flags and stanzas + -- TODO: The enumeration of OptionalStanza names is very brittle; + -- if a constructor is added to the datatype we won't notice it here + Just i -> do + vs <- get + let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i + flags = M.keys finfo + stanzas = [TestStanzas, BenchStanzas] + forM_ flags $ \fn -> do + let flag = FN (PI (lgPackage lg) i) fn + verifyFlag' flag lg + forM_ stanzas $ \sn -> do + let stanza = SN (PI (lgPackage lg) i) sn + verifyStanza' stanza lg + +verifyFlag :: QFN -> UpdateState () +verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do + vs <- get + -- We can only pick a flag after picking an instance; link group must exist + verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn) + +verifyStanza :: QSN -> UpdateState () +verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do + vs <- get + -- We can only pick a stanza after picking an instance; link group must exist + verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn) + +-- | Verify that all packages in the link group agree on flag assignments +-- +-- For the given flag and the link group, obtain all assignments for the flag +-- that have already been made for link group members, and check that they are +-- equal. +verifyFlag' :: FN PN -> LinkGroup -> UpdateState () +verifyFlag' (FN (PI pn i) fn) lg = do + vs <- get + let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsFlags vs) flags + if allEqual (catMaybes vals) -- We ignore not-yet assigned flags + then return () + else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg + , "flag \"" ++ unFlagName fn ++ "\" incompatible" + ) + +-- | Verify that all packages in the link group agree on stanza assignments +-- +-- For the given stanza and the link group, obtain all assignments for the +-- stanza that have already been made for link group members, and check that +-- they are equal. +-- +-- This function closely mirrors 'verifyFlag''. +verifyStanza' :: SN PN -> LinkGroup -> UpdateState () +verifyStanza' (SN (PI pn i) sn) lg = do + vs <- get + let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg)) + vals = map (`M.lookup` vsStanzas vs) stanzas + if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas + then return () + else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg + , "stanza \"" ++ showStanza sn ++ "\" incompatible" + ) + +{------------------------------------------------------------------------------- + Link groups +-------------------------------------------------------------------------------} + +-- | Set of packages that must be linked together +-- +-- A LinkGroup is between several qualified package names. In the validation +-- state, we maintain a map vsLinks from qualified package names to link groups. +-- There is an invariant that for all members of a link group, vsLinks must map +-- to the same link group. The function updateLinkGroup can be used to +-- re-establish this invariant after creating or expanding a LinkGroup. +data LinkGroup = LinkGroup { + -- | The name of the package of this link group + lgPackage :: PN + + -- | The canonical member of this link group (the one where we picked + -- a concrete instance). Once we have picked a canonical member, all + -- other packages must link to this one. + -- + -- We may not know this yet (if we are constructing link groups + -- for dependencies) + , lgCanon :: Maybe (PI PackagePath) + + -- | The members of the link group + , lgMembers :: Set PackagePath + + -- | The set of variables that should be added to the conflict set if + -- something goes wrong with this link set (in addition to the members + -- of the link group itself) + , lgBlame :: ConflictSet + } + deriving (Show, Eq) + +-- | Invariant for the set of link groups: every element in the link group +-- must be pointing to the /same/ link group +lgInvariant :: Map QPN LinkGroup -> Bool +lgInvariant links = all invGroup (M.elems links) + where + invGroup :: LinkGroup -> Bool + invGroup lg = allEqual $ map (`M.lookup` links) members + where + members :: [QPN] + members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) + +-- | Package version of this group +-- +-- This is only known once we have picked a canonical element. +lgInstance :: LinkGroup -> Maybe I +lgInstance = fmap (\(PI _ i) -> i) . lgCanon + +showLinkGroup :: LinkGroup -> String +showLinkGroup lg = + "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" + where + showMember :: PackagePath -> String + showMember pp = case lgCanon lg of + Just (PI pp' _i) | pp == pp' -> "*" + _otherwise -> "" + ++ case lgInstance lg of + Nothing -> showQPN (qpn pp) + Just i -> showPI (PI (qpn pp) i) + + qpn :: PackagePath -> QPN + qpn pp = Q pp (lgPackage lg) + +-- | Creates a link group that contains a single member. +lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup +lgSingleton (Q pp pn) canon = LinkGroup { + lgPackage = pn + , lgCanon = canon + , lgMembers = S.singleton pp + , lgBlame = CS.empty + } + +lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge blame lg lg' = do + canon <- pick (lgCanon lg) (lgCanon lg') + return LinkGroup { + lgPackage = lgPackage lg + , lgCanon = canon + , lgMembers = lgMembers lg `S.union` lgMembers lg' + , lgBlame = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg'] + } + where + pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) + pick Nothing Nothing = Right Nothing + pick (Just x) Nothing = Right $ Just x + pick Nothing (Just y) = Right $ Just y + pick (Just x) (Just y) = + if x == y then Right $ Just x + else Left ( CS.unions [ + CS.fromList blame + , lgConflictSet lg + , lgConflictSet lg' + ] + , "cannot merge " ++ showLinkGroup lg + ++ " and " ++ showLinkGroup lg' + ) + +lgConflictSet :: LinkGroup -> ConflictSet +lgConflictSet lg = + CS.fromList (map aux (S.toList (lgMembers lg))) + `CS.union` lgBlame lg + where + aux pp = P (Q pp (lgPackage lg)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +allEqual :: Eq a => [a] -> Bool +allEqual [] = True +allEqual [_] = True +allEqual (x:y:ys) = x == y && allEqual (y:ys) + +concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c]) +concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f diff --git a/Distribution/Solver/Modular/Log.hs b/Distribution/Solver/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Log.hs @@ -0,0 +1,92 @@ +module Distribution.Solver.Modular.Log + ( Log + , logToProgress + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Data.List as L + +import Distribution.Solver.Types.Progress + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Tree (FailReason(..)) +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Verbosity + +-- | The 'Log' datatype. +-- +-- Represents the progress of a computation lazily. +-- +-- Parameterized over the type of actual messages and the final result. +type Log m a = Progress m (ConflictSet, ConflictMap) a + +messages :: Progress step fail done -> [step] +messages = foldProgress (:) (const []) (const []) + +data Exhaustiveness = Exhaustive | BackjumpLimitReached + +-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. +-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the +-- limit is 'Just 0', backtracking is completely disabled. +logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a +logToProgress verbosity mbj l = + let es = proc (Just 0) l -- catch first error (always) + ms = proc mbj l + in go es es -- trace for first error + (showMessages (const True) True ms) -- run with backjump limit applied + where + -- Proc takes the allowed number of backjumps and a 'Progress' and explores the + -- messages until the maximum number of backjumps has been reached. It filters out + -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates + -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the + -- original result. + proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b + proc _ (Done x) = Done x + proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm) + proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _))) + | cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one + proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available + proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs) + proc mbj' (Step x xs) = Step x (proc mbj' xs) + + -- The first two arguments are both supposed to be the log up to the first error. + -- That's the error that will always be printed in case we do not find a solution. + -- We pass this log twice, because we evaluate it in parallel with the full log, + -- but we also want to retain the reference to its beginning for when we print it. + -- This trick prevents a space leak! + -- + -- The third argument is the full log, ending with either the solution or the + -- exhaustiveness and final conflict set. + go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b + -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b + -> Progress String (Exhaustiveness, ConflictSet, ConflictMap) b + -> Progress String String b + go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs) + go ms r (Step x xs) = Step x (go ms r xs) + go ms (Step _ ns) r = go ms ns r + go ms (Fail (_, cs', _)) (Fail (exh, cs, cm)) = Fail $ + "Could not resolve dependencies:\n" ++ + unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) ++ + case exh of + Exhaustive -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + where + showCS = if verbosity > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + BackjumpLimitReached -> + "Backjump limit reached (" ++ currlimit mbj ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" + go _ _ (Done s) = Done s + go _ (Done _) (Fail _) = Fail $ + -- Should not happen: Second argument is the log up to first error, + -- third one is the entire log. Therefore it should never happen that + -- the second log finishes with 'Done' and the third log with 'Fail'. + "Could not resolve dependencies; something strange happened." diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Message.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BangPatterns #-} + +module Distribution.Solver.Modular.Message ( + Message(..), + showMessages + ) where + +import qualified Data.List as L +import Prelude hiding (pi) + +import Distribution.Text -- from Cabal + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree + ( FailReason(..), POption(..) ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Progress + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP QPN POption + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Success + | Failure ConflictSet FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- Takes an additional relevance predicate. The predicate gets a stack of goal +-- variables and can decide whether messages regarding these goals are relevant. +-- You can plug in 'const True' if you're interested in a full trace. If you +-- want a slice of the trace concerning a particular conflict set, then plug in +-- a predicate returning 'True' on the empty stack and if the head is in the +-- conflict set. +-- +-- The second argument indicates if the level numbers should be shown. This is +-- recommended for any trace that involves backtracking, because only the level +-- numbers will allow to keep track of backjumps. +showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b +showMessages p sl = go [] 0 + where + -- The stack 'v' represents variables that are currently assigned by the + -- solver. 'go' pushes a variable for a recursive call when it encounters + -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'. + -- When 'go' processes a package goal, or a package goal followed by a + -- 'Failure', it calls 'atLevel' with the goal variable at the head of the + -- stack so that the predicate can also select messages relating to package + -- goal choices. + go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b + go !_ !_ (Done x) = Done x + go !_ !_ (Fail x) = Fail x + -- complex patterns + go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + goPReject v l qpn [i] c fr ms + go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) + go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) + go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = + (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms) + go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = + (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms + -- the previous case potentially arises in the error output, because we remove the backjump itself + -- if we cut the log after the first error + go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = + (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms + go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = + let v' = add (P qpn) v + in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms) + go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) + | c == c' = go v l ms + -- standard display + go !v !l (Step Enter ms) = go v (l+1) ms + go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms + go !v !l (Step (TryP qpn i) ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms) + go !v !l (Step (TryF qfn b) ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) + go !v !l (Step (TryS qsn b) ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) + go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms) + go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log + go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms) + go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms) + + showPackageGoal :: QPN -> QGoalReason -> String + showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr + + showFailure :: ConflictSet -> FailReason -> String + showFailure c fr = "fail" ++ showFR c fr + + add :: Var QPN -> [Var QPN] -> [Var QPN] + add v vs = simplifyVar v : vs + + -- special handler for many subsequent package rejections + goPReject :: [Var QPN] + -> Int + -> QPN + -> [POption] + -> ConflictSet + -> FailReason + -> Progress Message a b + -> Progress String a b + goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) + | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms + goPReject v l qpn is c fr ms = + (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms) + + -- write a message, but only if it's relevant; we can also enable or disable the display of the current level + atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b + atLevel v l x xs + | sl && p v = let s = show l + in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs + | p v = Step x xs + | otherwise = xs + +showQPNPOpt :: QPN -> POption -> String +showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = + case linkedTo of + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption + Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + +showGR :: QGoalReason -> String +showGR UserGoal = " (user goal)" +showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" +showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" +showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" + +showFR :: ConflictSet -> FailReason -> String +showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" +showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ Broken = " (package is broken)" +showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ display vr ++ ")" +showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" +showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" +showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" +showFR _ ManualFlag = " (manual flag can only be changed explicitly)" +showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" +showFR _ MultipleInstances = " (multiple instances)" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" +showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" +-- The following are internal failures. They should not occur. In the +-- interest of not crashing unnecessarily, we still just print an error +-- message though. +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" + +constraintSource :: ConstraintSource -> String +constraintSource src = "constraint from " ++ showConstraintSource src diff --git a/Distribution/Solver/Modular/PSQ.hs b/Distribution/Solver/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/PSQ.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.PSQ + ( PSQ(..) -- Unit test needs constructor access + , casePSQ + , cons + , length + , lookup + , filter + , filterIfAny + , filterIfAnyByKeys + , filterKeys + , firstOnly + , fromList + , isZeroOrOne + , keys + , map + , mapKeys + , mapWithKey + , maximumBy + , minimumBy + , null + , prefer + , preferByKeys + , snoc + , sortBy + , sortByKeys + , splits + , toList + , union + ) where + +-- Priority search queues. +-- +-- I am not yet sure what exactly is needed. But we need a data structure with +-- key-based lookup that can be sorted. We're using a sequence right now with +-- (inefficiently implemented) lookup, because I think that queue-based +-- operations and sorting turn out to be more efficiency-critical in practice. + +import Control.Arrow (first, second) + +import qualified Data.Foldable as F +import Data.Function +import qualified Data.List as S +import Data.Ord (comparing) +import Data.Traversable +import Prelude hiding (foldr, length, lookup, filter, null, map) + +newtype PSQ k v = PSQ [(k, v)] + deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (second f) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (k, v) : ys -> c k v (PSQ ys) + +splits :: PSQ k a -> PSQ k (a, PSQ k a) +splits = go id + where + go f xs = casePSQ xs + (PSQ []) + (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys)) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +maximumBy :: (k -> Int) -> PSQ k a -> (k, a) +maximumBy sel (PSQ xs) = + S.minimumBy (flip (comparing (sel . fst))) xs + +minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a +minimumBy sel (PSQ xs) = + PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] + +-- | Sort the list so that values satisfying the predicate are first. +prefer :: (a -> Bool) -> PSQ k a -> PSQ k a +prefer p = sortBy $ flip (comparing p) + +-- | Sort the list so that keys satisfying the predicate are first. +preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +preferByKeys p = sortByKeys $ flip (comparing p) + +-- | Will partition the list according to the predicate. If +-- there is any element that satisfies the precidate, then only +-- the elements satisfying the predicate are returned. +-- Otherwise, the rest is returned. +-- +filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a +filterIfAny p (PSQ xs) = + let + (pro, con) = S.partition (p . snd) xs + in + if S.null pro then PSQ con else PSQ pro + +-- | Variant of 'filterIfAny' that takes a predicate on the keys +-- rather than on the values. +-- +filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterIfAnyByKeys p (PSQ xs) = + let + (pro, con) = S.partition (p . fst) xs + in + if S.null pro then PSQ con else PSQ pro + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +isZeroOrOne :: PSQ k a -> Bool +isZeroOrOne (PSQ []) = True +isZeroOrOne (PSQ [_]) = True +isZeroOrOne _ = False + +firstOnly :: PSQ k a -> PSQ k a +firstOnly (PSQ []) = PSQ [] +firstOnly (PSQ (x : _)) = PSQ [x] + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs + +union :: PSQ k a -> PSQ k a -> PSQ k a +union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/Distribution/Solver/Modular/Package.hs b/Distribution/Solver/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Package.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Package + ( I(..) + , Loc(..) + , PackageId + , PackageIdentifier(..) + , PackageName, mkPackageName, unPackageName + , PkgconfigName, mkPkgconfigName, unPkgconfigName + , PI(..) + , PN + , QPV + , instI + , makeIndependent + , primaryPP + , setupPP + , showI + , showPI + , unPN + ) where + +import Data.List as L + +import Distribution.Package -- from Cabal +import Distribution.Text (display) + +import Distribution.Solver.Modular.Version +import Distribution.Solver.Types.PackagePath + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN = unPackageName + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Qualified PV + +-- | Package id. Currently just a black-box string. +type PId = UnitId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I Ver Loc + deriving (Eq, Ord, Show) + +-- | String representation of an instance. +showI :: I -> String +showI (I v InRepo) = showVer v +showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid + where + -- A hack to extract the beginning of the package ABI hash + shortId = snip (splitAt 4) (++ "...") + . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) + . display + snip p f xs = case p xs of + (ys, zs) -> (if L.null zs then id else f) ys + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show, Functor) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +instI :: I -> Bool +instI (I _ (Inst _)) = True +instI _ = False + +-- | Is the package in the primary group of packages. This is used to +-- determine (1) if we should try to establish stanza preferences +-- for this goal, and (2) whether or not a user specified @--constraint@ +-- should apply to this dependency (grep 'primaryPP' to see the +-- use sites). In particular this does not include packages pulled in +-- as setup deps. +-- +primaryPP :: PackagePath -> Bool +primaryPP (PackagePath _ns q) = go q + where + go QualToplevel = True + go (QualBase _) = True + go (QualSetup _) = False + go (QualExe _ _) = False + +-- | Is the package a dependency of a setup script. This is used to +-- establish whether or not certain constraints should apply to this +-- dependency (grep 'setupPP' to see the use sites). +-- +setupPP :: PackagePath -> Bool +setupPP (PackagePath _ns (QualSetup _)) = True +setupPP (PackagePath _ns _) = False + +-- | Create artificial parents for each of the package names, making +-- them all independent. +makeIndependent :: [PN] -> [QPN] +makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] + , let pp = PackagePath (Independent i) QualToplevel + ] diff --git a/Distribution/Solver/Modular/Preference.hs b/Distribution/Solver/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Preference.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Reordering or pruning the tree in order to prefer or make certain choices. +module Distribution.Solver.Modular.Preference + ( avoidReinstalls + , deferSetupChoices + , deferWeakFlagChoices + , enforceManualFlags + , enforcePackageConstraints + , enforceSingleInstanceRestriction + , firstGoal + , preferBaseGoalChoice + , preferLinked + , preferPackagePreferences + , preferReallyEasyGoalChoices + , requireInstalled + , sortGoals + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Data.Function (on) +import qualified Data.List as L +import qualified Data.Map as M +import Control.Monad.Reader hiding (sequence) +import Data.Traversable (sequence) + +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.PSQ as P +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a +-- list of weight-calculating functions in order to avoid sorting the package +-- choices multiple times. Each function takes the package name, sorted list of +-- children's versions, and package option. 'addWeights' prepends the new +-- weights to the existing weights, which gives precedence to preferences that +-- are applied later. +addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c +addWeights fs = trav go + where + go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) + go (PChoiceF qpn@(Q _ pn) rdm x cs) = + let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) + weights k = [f pn sortedVersions k | f <- fs] + + elemsToWhnf :: [a] -> () + elemsToWhnf = foldr seq () + in PChoiceF qpn rdm x + -- Evaluate the children's versions before evaluating any of the + -- subtrees, so that 'sortedVersions' doesn't hold onto all of the + -- subtrees (referenced by cs) and cause a space leak. + (elemsToWhnf sortedVersions `seq` + W.mapWeightsWithKey (\k w -> weights k ++ w) cs) + go x = x + +addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c +addWeight f = addWeights [f] + +version :: POption -> Ver +version (POption (I v _) _) = v + +-- | Prefer to link packages whenever possible. +preferLinked :: Tree d c -> Tree d c +preferLinked = addWeight (const (const linked)) + where + linked (POption _ Nothing) = 1 + linked (POption _ (Just _)) = 0 + +-- Works by setting weights on choice nodes. Also applies stanza preferences. +preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c +preferPackagePreferences pcs = + preferPackageStanzaPreferences pcs . + addWeights [ + \pn _ opt -> preferred pn opt + + -- Note that we always rank installed before uninstalled, and later + -- versions before earlier, but we can change the priority of the + -- two orderings. + , \pn vs opt -> case preference pn of + PreferInstalled -> installed opt + PreferLatest -> latest vs opt + , \pn vs opt -> case preference pn of + PreferInstalled -> latest vs opt + PreferLatest -> installed opt + ] + where + -- Prefer packages with higher version numbers over packages with + -- lower version numbers. + latest :: [Ver] -> POption -> Weight + latest sortedVersions opt = + let l = length sortedVersions + index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions + in fromIntegral index / fromIntegral l + + preference :: PN -> InstalledPreference + preference pn = + let PackagePreferences _ ipref _ = pcs pn + in ipref + + -- | Prefer versions satisfying more preferred version ranges. + preferred :: PN -> POption -> Weight + preferred pn opt = + let PackagePreferences vrs _ _ = pcs pn + in fromIntegral . negate . L.length $ + L.filter (flip checkVR (version opt)) vrs + + -- Prefer installed packages over non-installed packages. + installed :: POption -> Weight + installed (POption (I _ (Inst _)) _) = 0 + installed _ = 1 + +-- | Traversal that tries to establish package stanza enable\/disable +-- preferences. Works by reordering the branches of stanza choices. +preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c +preferPackageStanzaPreferences pcs = trav go + where + go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) rdm gr _tr ts) + | primaryPP pp && enableStanzaPref pn s = + -- move True case first to try enabling the stanza + let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts + weight k = if k then 0 else 1 + -- defer the choice by setting it to weak + in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' + go x = x + + enableStanzaPref :: PN -> OptionalStanza -> Bool + enableStanzaPref pn s = + let PackagePreferences _ _ spref = pcs pn + in s `elem` spref + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: forall d c. QPN + -> ConflictSet + -> I + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go i prop + else r + where + go :: I -> PackageProperty -> Tree d c + go (I v _) (PackagePropertyVersion vr) + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr src) + go _ PackagePropertyInstalled + | instI i = r + | otherwise = Fail c (GlobalConstraintInstalled src) + go _ PackagePropertySource + | not (instI i) = r + | otherwise = Fail c (GlobalConstraintSource src) + go _ _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintF :: forall d c. QPN + -> Flag + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyFlags fa) = + case L.lookup f fa of + Nothing -> r + Just b | b == b' -> r + | otherwise -> Fail c (GlobalConstraintFlag src) + go _ = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintS :: forall d c. QPN + -> OptionalStanza + -> ConflictSet + -> Bool + -> LabeledPackageConstraint + -> Tree d c + -> Tree d c +processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r + where + go :: PackageProperty -> Tree d c + go (PackagePropertyStanzas ss) = + if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) + else r + go _ = r + +-- | Traversal that tries to establish various kinds of user constraints. Works +-- by selectively disabling choices that have been ruled out by global user +-- constraints. +enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] + -> Tree d c + -> Tree d c +enforcePackageConstraints pcs = trav go + where + go (PChoiceF qpn@(Q _ pn) rdm gr ts) = + let c = varToConflictSet (P qpn) + -- compose the transformation functions for each of the relevant constraint + g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) + id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn rdm gr (W.mapWithKey g ts) + go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m d ts) = + let c = varToConflictSet (F qfn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) + go (SChoiceF qsn@(SN (PI qpn@(Q _ pn) _) f) rdm gr tr ts) = + let c = varToConflictSet (S qsn) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) + id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) + go x = x + +-- | Transformation that tries to enforce the rule that manual flags can only be +-- set by the user. +-- +-- If there are no constraints on a manual flag, this function prunes all but +-- the default value. If there are constraints, then the flag is allowed to have +-- the values specified by the constraints. Note that the type used for flag +-- values doesn't need to be Bool. +-- +-- This function makes an exception for the case where there are multiple goals +-- for a single package (with different qualifiers), and flag constraints for +-- manual flag x only apply to some of those goals. In that case, we allow the +-- unconstrained goals to use the default value for x OR any of the values in +-- the constraints on x (even though the constraints don't apply), in order to +-- allow the unconstrained goals to be linked to the constrained goals. See +-- https://github.com/haskell/cabal/issues/4299. +-- +-- This function does not enforce any of the constraints, since that is done by +-- 'enforcePackageConstraints'. +enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c +enforceManualFlags pcs = trav go + where + go (FChoiceF qfn@(FN (PI (Q _ pn) _) fn) rdm gr tr Manual d ts) = + FChoiceF qfn rdm gr tr Manual d $ + let -- A list of all values specified by constraints on 'fn', + -- regardless of scope. + flagConstraintValues :: [Bool] + flagConstraintValues = + [ flagVal + | let lpcs = M.findWithDefault [] pn pcs + , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs + , (fn', flagVal) <- fa + , fn' == fn ] + + -- Prune flag values that are not the default and do not match any + -- of the constraints. + restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c + restrictToggling flagDefault constraintVals flagVal r = + if flagVal `elem` constraintVals || flagVal == flagDefault + then r + else Fail (varToConflictSet (F qfn)) ManualFlag + + in W.mapWithKey (restrictToggling d flagConstraintValues) ts + go x = x + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c +requireInstalled p = trav go + where + go (PChoiceF v@(Q _ pn) rdm gr cs) + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs + where + installed (POption (I _ (Inst _)) _) x = x + installed _ _ = Fail (varToConflictSet (P v)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- they are, perhaps this should just result in trying to reinstall those other +-- packages as well. However, doing this all neatly in one pass would require to +-- change the builder, or at least to change the goal set after building. +avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c +avoidReinstalls p = trav go + where + go (PChoiceF qpn@(Q _ pn) rdm gr cs) + | p pn = PChoiceF qpn rdm gr disableReinstalls + | otherwise = PChoiceF qpn rdm gr cs + where + disableReinstalls = + let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] + in W.mapWithKey (notReinstall installed) cs + + notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + Fail (varToConflictSet (P qpn)) CannotReinstall + notReinstall _ _ x = + x + go x = x + +-- | Sort all goals using the provided function. +sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c +sortGoals variableOrder = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) + go x = x + + goalOrder :: Goal QPN -> Goal QPN -> Ordering + goalOrder = variableOrder `on` (varToVariable . goalToVar) + + varToVariable :: Var QPN -> Variable QPN + varToVariable (P qpn) = PackageVar qpn + varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn + varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: Tree d c -> Tree d c +firstGoal = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible by pruning all other goals when base is available. In nearly +-- all cases, there's a single choice for the base package. Also, fixing +-- base early should lead to better error messages. +preferBaseGoalChoice :: Tree d c -> Tree d c +preferBaseGoalChoice = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) + go x = x + + isBase :: Goal QPN -> Bool + isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" + isBase _ = False + +-- | Deal with setup dependencies after regular dependencies, so that we can +-- will link setup dependencies against package dependencies when possible +deferSetupChoices :: Tree d c -> Tree d c +deferSetupChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs) + go x = x + + noSetup :: Goal QPN -> Bool + noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False + noSetup _ = True + +-- | Transformation that tries to avoid making weak flag choices early. +-- Weak flags are trivial flags (not influencing dependencies) or such +-- flags that are explicitly declared to be weak in the index. +deferWeakFlagChoices :: Tree d c -> Tree d c +deferWeakFlagChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) + go x = x + + noWeakStanza :: Tree d c -> Bool + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True + + noWeakFlag :: Tree d c -> Bool + noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False + noWeakFlag _ = True + +-- | Transformation that prefers goals with lower branching degrees. +-- +-- When a goal choice node has at least one goal with zero or one children, this +-- function prunes all other goals. This transformation can help the solver find +-- a solution in fewer steps by allowing it to backtrack sooner when it is +-- exploring a subtree with no solutions. However, each step is more expensive. +preferReallyEasyGoalChoices :: Tree d c -> Tree d c +preferReallyEasyGoalChoices = trav go + where + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) + go x = x + +-- | Monad used internally in enforceSingleInstanceRestriction +-- +-- For each package instance we record the goal for which we picked a concrete +-- instance. The SIR means that for any package instance there can only be one. +type EnforceSIR = Reader (Map (PI PN) QPN) + +-- | Enforce ghc's single instance restriction +-- +-- From the solver's perspective, this means that for any package instance +-- (that is, package name + package version) there can be at most one qualified +-- goal resolving to that instance (there may be other goals _linking_ to that +-- instance however). +enforceSingleInstanceRestriction :: Tree d c -> Tree d c +enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go + where + go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) + + -- We just verify package choices. + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) cs) + go _otherwise = + innM _otherwise + + -- The check proper + goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) + goP qpn@(Q _ pn) (POption i linkedTo) r = do + let inst = PI pn i + env <- ask + case (linkedTo, M.lookup inst env) of + (Just _, _) -> + -- For linked nodes we don't check anything + r + (Nothing, Nothing) -> + -- Not linked, not already used + local (M.insert inst qpn) r + (Nothing, Just qpn') -> do + -- Not linked, already used. This is an error + return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances diff --git a/Distribution/Solver/Modular/RetryLog.hs b/Distribution/Solver/Modular/RetryLog.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/RetryLog.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE Rank2Types #-} +module Distribution.Solver.Modular.RetryLog + ( RetryLog + , toProgress + , fromProgress + , mapFailure + , retry + , failWith + , succeedWith + , continueWith + , tryWith + ) where + +import Distribution.Solver.Modular.Message +import Distribution.Solver.Types.Progress + +-- | 'Progress' as a difference list that allows efficient appends at failures. +newtype RetryLog step fail done = RetryLog { + unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) + -> Progress step fail2 done + } + +-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. +toProgress :: RetryLog step fail done -> Progress step fail done +toProgress (RetryLog f) = f Fail + +-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. +fromProgress :: Progress step fail done -> RetryLog step fail done +fromProgress l = RetryLog $ \f -> go f l + where + go :: (fail1 -> Progress step fail2 done) + -> Progress step fail1 done + -> Progress step fail2 done + go _ (Done d) = Done d + go f (Fail failure) = f failure + go f (Step m ms) = Step m (go f ms) + +-- | /O(1)/. Apply a function to the failure value in a log. +mapFailure :: (fail1 -> fail2) + -> RetryLog step fail1 done + -> RetryLog step fail2 done +mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) + +-- | /O(1)/. If the first log leads to failure, continue with the second. +retry :: RetryLog step fail1 done + -> (fail1 -> RetryLog step fail2 done) + -> RetryLog step fail2 done +retry (RetryLog f) g = + RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog + +-- | /O(1)/. Create a log with one message before a failure. +failWith :: step -> fail -> RetryLog step fail done +failWith m failure = RetryLog $ \f -> Step m (f failure) + +-- | /O(1)/. Create a log with one message before a success. +succeedWith :: step -> done -> RetryLog step fail done +succeedWith m d = RetryLog $ const $ Step m (Done d) + +-- | /O(1)/. Prepend a message to a log. +continueWith :: step + -> RetryLog step fail done + -> RetryLog step fail done +continueWith m (RetryLog f) = RetryLog $ Step m . f + +-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert +-- 'Leave' before the failure if the log fails. +tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done +tryWith m f = + RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Solver.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE CPP #-} +#ifdef DEBUG_TRACETREE +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +module Distribution.Solver.Modular.Solver + ( SolverConfig(..) + , solve + ) where + +import Data.Map as M +import Data.List as L +import Data.Set as S +import Distribution.Verbosity +import Distribution.Version + +import Distribution.Compiler (CompilerInfo) + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Builder +import Distribution.Solver.Modular.Cycles +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Explore +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Log +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package +import qualified Distribution.Solver.Modular.Preference as P +import Distribution.Solver.Modular.Validate +import Distribution.Solver.Modular.Linking +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.Tree +import qualified Distribution.Solver.Modular.PSQ as PSQ + +import Distribution.Simple.Setup (BooleanFlag(..)) + +#ifdef DEBUG_TRACETREE +import Distribution.Solver.Modular.Flag +import qualified Distribution.Solver.Modular.ConflictSet as CS +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import qualified Distribution.Text as T + +import Debug.Trace.Tree (gtraceJson) +import Debug.Trace.Tree.Simple +import Debug.Trace.Tree.Generic +import Debug.Trace.Tree.Assoc (Assoc(..)) +#endif + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + reorderGoals :: ReorderGoals, + countConflicts :: CountConflicts, + independentGoals :: IndependentGoals, + avoidReinstalls :: AvoidReinstalls, + shadowPkgs :: ShadowPkgs, + strongFlags :: StrongFlags, + allowBootLibInstalls :: AllowBootLibInstalls, + maxBackjumps :: Maybe Int, + enableBackjumping :: EnableBackjumping, + solveExecutables :: SolveExecutables, + goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + solverVerbosity :: Verbosity +} + +-- | Run all solver phases. +-- +-- In principle, we have a valid tree after 'validationPhase', which +-- means that every 'Done' node should correspond to valid solution. +-- +-- There is one exception, though, and that is cycle detection, which +-- has been added relatively recently. Cycles are only removed directly +-- before exploration. +-- +solve :: SolverConfig -- ^ solver parameters + -> CompilerInfo + -> Index -- ^ all available packages as an index + -> PkgConfigDb -- ^ available pkg-config pkgs + -> (PN -> PackagePreferences) -- ^ preferences + -> Map PN [LabeledPackageConstraint] -- ^ global constraints + -> Set PN -- ^ global goals + -> Log Message (Assignment, RevDepMap) +solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = + explorePhase $ + detectCycles $ + heuristicsPhase $ + preferencesPhase $ + validationPhase $ + prunePhase $ + buildPhase + where + explorePhase = backjumpAndExplore (enableBackjumping sc) (countConflicts sc) + detectCycles = traceTree "cycles.json" id . detectCyclesPhase + heuristicsPhase = + let heuristicsTree = traceTree "heuristics.json" id + in case goalOrder sc of + Nothing -> goalChoiceHeuristics . + heuristicsTree . + P.deferSetupChoices . + P.deferWeakFlagChoices . + P.preferBaseGoalChoice + Just order -> P.firstGoal . + heuristicsTree . + P.sortGoals order + preferencesPhase = P.preferLinked . + P.preferPackagePreferences userPrefs + validationPhase = traceTree "validated.json" id . + P.enforcePackageConstraints userConstraints . + P.enforceManualFlags userConstraints . + P.enforceSingleInstanceRestriction . + validateLinking idx . + validateTree cinfo idx pkgConfigDB + prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . + (if asBool (allowBootLibInstalls sc) + then id + else P.requireInstalled (`elem` nonInstallable)) + buildPhase = traceTree "build.json" id + $ buildTree idx (independentGoals sc) (S.toList userGoals) + + -- packages that can never be installed or upgraded + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Client.Dependency" as well + nonInstallable :: [PackageName] + nonInstallable = + L.map mkPackageName + [ "base" + , "ghc-prim" + , "integer-gmp" + , "integer-simple" + , "template-haskell" + ] + + -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which + -- prefers (keeps) goals only if the have 0 or 1 enabled choice. + -- + -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes + -- to just a single option. This was a way to work around a space leak that was + -- unnecessary and is now fixed, so we no longer do it. + -- + -- If --count-conflicts is active, it will then choose among the remaining goals + -- the one that has been responsible for the most conflicts so far. + -- + -- Otherwise, we simply choose the first remaining goal. + -- + goalChoiceHeuristics + | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices + | otherwise = id {- P.firstGoal -} + +-- | Dump solver tree to a file (in debugging mode) +-- +-- This only does something if the @debug-tracetree@ configure argument was +-- given; otherwise this is just the identity function. +traceTree :: +#ifdef DEBUG_TRACETREE + GSimpleTree a => +#endif + FilePath -- ^ Output file + -> (a -> a) -- ^ Function to summarize the tree before dumping + -> a -> a +#ifdef DEBUG_TRACETREE +traceTree = gtraceJson +#else +traceTree _ _ = id +#endif + +#ifdef DEBUG_TRACETREE +instance GSimpleTree (Tree d c) where + fromGeneric = go + where + go :: Tree d c -> SimpleTree + go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq + go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq + go (Done _rdm _s) = Node "D" $ Assoc [] + go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] + + psqToList :: W.WeightedPSQ w k v -> [(k, v)] + psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList + + -- Show package choice + goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) + goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) + + -- Show flag or stanza choice + goFS :: Bool -> Tree d c -> (String, SimpleTree) + goFS val subtree = (show val, go subtree) + + -- Show goal choice + goG :: Goal QPN -> Tree d c -> (String, SimpleTree) + goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) + + -- Variation on 'showGR' that produces shorter strings + -- (Actually, QGoalReason records more info than necessary: we only need + -- to know the variable that introduced the goal, not the value assigned + -- to that variable) + shortGR :: QGoalReason -> String + shortGR UserGoal = "user" + shortGR (PDependency (PI nm _)) = showQPN nm + shortGR (FDependency nm _) = showQFN nm + shortGR (SDependency nm) = showQSN nm + + -- Show conflict set + goCS :: ConflictSet -> String + goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" +#endif + +-- | Replace all goal reasons with a dummy goal reason in the tree +-- +-- This is useful for debugging (when experimenting with the impact of GRs) +_removeGR :: Tree d c -> Tree d QGoalReason +_removeGR = trav go + where + go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason + + goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) + goG = PSQ.fromList + . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) + . PSQ.toList + + dummy :: QGoalReason + dummy = PDependency + $ PI (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + (I (mkVersion [1]) InRepo) diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Tree.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.Tree + ( FailReason(..) + , POption(..) + , Tree(..) + , TreeF(..) + , Weight + , ana + , cata + , inn + , innM + , para + , trav + , zeroOrOneChoices + ) where + +import Control.Monad hiding (mapM, sequence) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM, sequence) + +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.Version +import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) +import qualified Distribution.Solver.Modular.WeightedPSQ as W +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.PackagePath + +type Weight = Double + +-- | Type of the search tree. Inlining the choice nodes for now. Weights on +-- package, flag, and stanza choices control the traversal order. +-- +-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes +-- (type 'c'). For example, during the final traversal, choice nodes contain the +-- variables that introduced the choices, and 'Done' nodes contain the +-- assignments for all variables. +-- +-- TODO: The weight type should be changed from [Double] to Double to avoid +-- giving too much weight to preferences that are applied later. +data Tree d c = + -- | Choose a version for a package (or choose to link) + PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) + + -- | Choose a value for a flag + -- + -- The Bool is the default value. + | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + + -- | Choose whether or not to enable a stanza + | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + + -- | Choose which choice to make next + -- + -- Invariants: + -- + -- * PSQ should never be empty + -- * For each choice we additionally record the 'QGoalReason' why we are + -- introducing that goal into tree. Note that most of the time we are + -- working with @Tree QGoalReason@; in that case, we must have the + -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' + -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason + -- recorded on that 'GoalChoice' node. + | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + + -- | We're done -- we found a solution! + | Done RevDepMap d + + -- | We failed to find a solution in this path through the tree + | Fail ConflictSet FailReason + deriving (Eq, Show) + +-- | A package option is a package instance with an optional linking annotation +-- +-- The modular solver has a number of package goals to solve for, and can only +-- pick a single package version for a single goal. In order to allow to +-- install multiple versions of the same package as part of a single solution +-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both +-- be qualified goals for @P@, allowing to pick a difference version of package +-- @P@ for @0.P@ and @1.P@. +-- +-- Linking is an essential part of this story. In addition to picking a specific +-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or +-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package +-- (and hence must have the same build time configuration, and their +-- dependencies must also be the exact same). +-- +-- See for details. +data POption = POption I (Maybe PackagePath) + deriving (Eq, Show) + +data FailReason = InconsistentInitialConstraints + | Conflicting [Dep QPN] + | CannotInstall + | CannotReinstall + | Shadowed + | Broken + | GlobalConstraintVersion VR ConstraintSource + | GlobalConstraintInstalled ConstraintSource + | GlobalConstraintSource ConstraintSource + | GlobalConstraintFlag ConstraintSource + | ManualFlag + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + | MultipleInstances + | DependenciesNotLinked String + | CyclicDependencies + deriving (Eq, Show) + +-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' +-- have the same meaning as in 'Tree'. +data TreeF d c a = + PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d + | FailF ConflictSet FailReason + deriving (Functor, Foldable, Traversable) + +out :: Tree d c -> TreeF d c (Tree d c) +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s ) = DoneF x s +out (Fail c x ) = FailF c x + +inn :: TreeF d c (Tree d c) -> Tree d c +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +inn (DoneF x s ) = Done x s +inn (FailF c x ) = Fail c x + +innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) +innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) +innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) +innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) +innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) +innM (DoneF x s ) = return $ Done x s +innM (FailF c x ) = return $ Fail c x + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree d c -> Bool +active (Fail _ _) = False +active _ = True + +-- | Approximates the number of active choices that are available in a node. +-- Note that we count goal choices as having one choice, always. +zeroOrOneChoices :: Tree d c -> Bool +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _ ) = True +zeroOrOneChoices (Done _ _ ) = True +zeroOrOneChoices (Fail _ _ ) = True + +-- | Catamorphism on trees. +cata :: (TreeF d c a -> a) -> Tree d c -> a +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +-- | Anamorphism on trees. +ana :: (a -> TreeF d c a) -> a -> Tree d c +ana psi = inn . fmap (ana psi) . psi diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Validate.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Distribution.Solver.Modular.Validate (validateTree) where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Applicative +import Control.Monad.Reader hiding (sequence) +import Data.List as L +import Data.Map as M +import Data.Set as S +import Data.Traversable +import Prelude hiding (sequence) + +import Language.Haskell.Extension (Extension, Language) + +import Distribution.Compiler (CompilerInfo(..)) + +import Distribution.Solver.Modular.Assignment +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.Package +import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version (VR) +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Distribution.Solver.Types.ComponentDeps (Component) + +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) + +-- In practice, most constraints are implication constraints (IF we have made +-- a number of choices, THEN we also have to ensure that). We call constraints +-- that for which the preconditions are fulfilled ACTIVE. We maintain a set +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + supportedExt :: Extension -> Bool, + supportedLang :: Language -> Bool, + presentPkgs :: PkgconfigName -> VR -> Bool, + index :: Index, + saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies + pa :: PreAssignment, + qualifyOptions :: QualifyOptions +} + +newtype Validate a = Validate (Reader ValidateState a) + deriving (Functor, Applicative, Monad, MonadReader ValidateState) + +runValidate :: Validate a -> ValidateState -> a +runValidate (Validate r) = runReader r + +validate :: Tree d c -> Validate (Tree d c) +validate = cata go + where + go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) + + go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) + go (FChoiceF qfn rdm gr b m d ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goF qfn rb t + Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts) + go (SChoiceF qsn rdm gr b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case W.lookup rb ts of + Just t -> goS qsn rb t + Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts + go (DoneF rdm s ) = pure (Done rdm s) + go (FailF c fr ) = pure (Fail c fr) + + -- What to do for package nodes ... + goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) + goP qpn@(Q _pp pn) (POption i _) r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + qo <- asks qualifyOptions + -- obtain dependencies and index-dictated exclusions introduced by the choice + let (PInfo deps _ mfr) = idx ! pn ! i + -- qualify the deps in the current scope + let qdeps = qualifyDeps qo qpn deps + -- the new active constraints are given by the instance we have chosen, + -- plus the dependency information we have for that instance + -- TODO: is the False here right? + let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) + -- We now try to extend the partial assignment with the new active constraints. + let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (varToConflictSet (P qpn)) fr) + _ -> case mnppa of + Left (c, d) -> -- We have an inconsistency. We can stop. + return (Fail c (Conflicting d)) + Right nppa -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r + + -- What to do for flag nodes ... + goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goF qfn@(FN (PI qpn _i) _f) b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (F qfn) b npfa psa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r + + -- What to do for stanza nodes (similar to flag nodes) ... + goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) + goS qsn@(SN (PI qpn _i) _f) b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + extSupported <- asks supportedExt -- obtain the supported extensions + langSupported <- asks supportedLang -- obtain the supported languages + pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (S qsn) b pfa npsa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + +-- | We try to extract as many concrete dependencies from the given flagged +-- dependencies as possible. We make use of all the flag knowledge we have +-- already acquired. +extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] +extractDeps fa sa deps = do + d <- deps + case d of + Simple sd _ -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> extractDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> [] + +-- | We try to find new dependencies that become available due to the given +-- flag or stanza choice. We therefore look for the choice in question, and then call +-- 'extractDeps' for everything underneath. +extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] +extractNewDeps v b fa sa = go + where + go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion) + go deps = do + d <- deps + case d of + Simple _ _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> L.map (resetVar v) $ + if b then extractDeps fa sa td else extractDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> L.map (resetVar v) $ + if b then extractDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Interface. +validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c +validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { + supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported + (\ es -> let s = S.fromList es in \ x -> S.member x s) + (compilerInfoExtensions cinfo) + , supportedLang = maybe (const True) + (flip L.elem) -- use list lookup because language list is small and no Ord instance + (compilerInfoLanguages cinfo) + , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb + , index = idx + , saved = M.empty + , pa = PA M.empty M.empty M.empty + , qualifyOptions = defaultQualifyOptions idx + } diff --git a/Distribution/Solver/Modular/Var.hs b/Distribution/Solver/Modular/Var.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Var.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.Solver.Modular.Var ( + Var(..) + , simplifyVar + , showVar + , varPI + ) where + +import Prelude hiding (pi) + +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Package +import Distribution.Solver.Types.PackagePath + +{------------------------------------------------------------------------------- + Variables +-------------------------------------------------------------------------------} + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show, Functor) + +-- | For computing conflict sets, we map flag choice vars to a +-- single flag choice. This means that all flag choices are treated +-- as interdependent. So if one flag of a package ends up in a +-- conflict set, then all flags are being treated as being part of +-- the conflict set. +simplifyVar :: Var qpn -> Var qpn +simplifyVar (P qpn) = P qpn +simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag")) +simplifyVar (S qsn) = S qsn + +showVar :: Var QPN -> String +showVar (P qpn) = showQPN qpn +showVar (F qfn) = showQFN qfn +showVar (S qsn) = showQSN qsn + +-- | Extract the package instance from a Var +varPI :: Var QPN -> (QPN, Maybe I) +varPI (P qpn) = (qpn, Nothing) +varPI (F (FN (PI qpn i) _)) = (qpn, Just i) +varPI (S (SN (PI qpn i) _)) = (qpn, Just i) diff --git a/Distribution/Solver/Modular/Version.hs b/Distribution/Solver/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/Version.hs @@ -0,0 +1,53 @@ +module Distribution.Solver.Modular.Version + ( Ver + , VR + , anyVR + , checkVR + , eqVR + , showVer + , showVR + , simplifyVR + , (.&&.) + , (.||.) + ) where + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Text -- from Cabal + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = display + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = display + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +(.&&.) = CV.intersectVersionRanges + +-- | Union of two version ranges. +(.||.) :: VR -> VR -> VR +(.||.) = CV.unionVersionRanges + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange diff --git a/Distribution/Solver/Modular/WeightedPSQ.hs b/Distribution/Solver/Modular/WeightedPSQ.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Modular/WeightedPSQ.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Distribution.Solver.Modular.WeightedPSQ ( + WeightedPSQ + , fromList + , toList + , keys + , weights + , isZeroOrOne + , filter + , lookup + , mapWithKey + , mapWeightsWithKey + , union + ) where + +import qualified Data.Foldable as F +import qualified Data.List as L +import Data.Ord (comparing) +import qualified Data.Traversable as T +import Prelude hiding (filter, lookup) + +-- | An association list that is sorted by weight. +-- +-- Each element has a key ('k'), value ('v'), and weight ('w'). All operations +-- that add elements or modify weights stably sort the elements by weight. +newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] + deriving (Eq, Show, Functor, F.Foldable, T.Traversable) + +-- | /O(N)/. +filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v +filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) + +-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. +isZeroOrOne :: WeightedPSQ w k v -> Bool +isZeroOrOne (WeightedPSQ []) = True +isZeroOrOne (WeightedPSQ [_]) = True +isZeroOrOne _ = False + +-- | /O(1)/. Return the elements in order. +toList :: WeightedPSQ w k v -> [(w, k, v)] +toList (WeightedPSQ xs) = xs + +-- | /O(N log N)/. +fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v +fromList = WeightedPSQ . L.sortBy (comparing triple_1) + +-- | /O(N)/. Return the weights in order. +weights :: WeightedPSQ w k v -> [w] +weights (WeightedPSQ xs) = L.map triple_1 xs + +-- | /O(N)/. Return the keys in order. +keys :: WeightedPSQ w k v -> [k] +keys (WeightedPSQ xs) = L.map triple_2 xs + +-- | /O(N)/. Return the value associated with the first occurrence of the give +-- key, if it exists. +lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v +lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs + +-- | /O(N log N)/. Update the weights. +mapWeightsWithKey :: Ord w2 + => (k -> w1 -> w2) + -> WeightedPSQ w1 k v + -> WeightedPSQ w2 k v +mapWeightsWithKey f (WeightedPSQ xs) = fromList $ + L.map (\ (w, k, v) -> (f k w, k, v)) xs + +-- | /O(N)/. Update the values. +mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 +mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ + L.map (\ (w, k, v) -> (w, k, f k v)) xs + +-- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all +-- elements. Elements from the first @WeightedPSQ@ come before elements in the +-- second when they have the same weight. +union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v +union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) + +triple_1 :: (x, y, z) -> x +triple_1 (x, _, _) = x + +triple_2 :: (x, y, z) -> y +triple_2 (_, y, _) = y + +triple_3 :: (x, y, z) -> z +triple_3 (_, _, z) = z diff --git a/Distribution/Solver/Types/ComponentDeps.hs b/Distribution/Solver/Types/ComponentDeps.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/ComponentDeps.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Fine-grained package dependencies +-- +-- Like many others, this module is meant to be "double-imported": +-- +-- > import Distribution.Solver.Types.ComponentDeps ( +-- > Component +-- > , ComponentDep +-- > , ComponentDeps +-- > ) +-- > import qualified Distribution.Solver.Types.ComponentDeps as CD +module Distribution.Solver.Types.ComponentDeps ( + -- * Fine-grained package dependencies + Component(..) + , componentNameToComponent + , ComponentDep + , ComponentDeps -- opaque + -- ** Constructing ComponentDeps + , empty + , fromList + , singleton + , insert + , zip + , filterDeps + , fromLibraryDeps + , fromSetupDeps + , fromInstalled + -- ** Deconstructing ComponentDeps + , toList + , flatDeps + , nonSetupDeps + , libraryDeps + , setupDeps + , select + ) where + +import Prelude () +import Distribution.Types.UnqualComponentName +import Distribution.Client.Compat.Prelude hiding (empty,zip) + +import qualified Data.Map as Map +import Data.Foldable (fold) + +import qualified Distribution.Types.ComponentName as CN + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +-- | Component of a package. +data Component = + ComponentLib + | ComponentSubLib UnqualComponentName + | ComponentFLib UnqualComponentName + | ComponentExe UnqualComponentName + | ComponentTest UnqualComponentName + | ComponentBench UnqualComponentName + | ComponentSetup + deriving (Show, Eq, Ord, Generic) + +instance Binary Component + +-- | Dependency for a single component. +type ComponentDep a = (Component, a) + +-- | Fine-grained dependencies for a package. +-- +-- Typically used as @ComponentDeps [Dependency]@, to represent the list of +-- dependencies for each named component within a package. +-- +newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } + deriving (Show, Functor, Eq, Ord, Generic) + +instance Semigroup a => Monoid (ComponentDeps a) where + mempty = ComponentDeps Map.empty + mappend = (<>) + +instance Semigroup a => Semigroup (ComponentDeps a) where + ComponentDeps d <> ComponentDeps d' = + ComponentDeps (Map.unionWith (<>) d d') + +instance Foldable ComponentDeps where + foldMap f = foldMap f . unComponentDeps + +instance Traversable ComponentDeps where + traverse f = fmap ComponentDeps . traverse f . unComponentDeps + +instance Binary a => Binary (ComponentDeps a) + +componentNameToComponent :: CN.ComponentName -> Component +componentNameToComponent (CN.CLibName) = ComponentLib +componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s +componentNameToComponent (CN.CFLibName s) = ComponentFLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +empty :: ComponentDeps a +empty = ComponentDeps $ Map.empty + +fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a +fromList = ComponentDeps . Map.fromListWith mappend + +singleton :: Component -> a -> ComponentDeps a +singleton comp = ComponentDeps . Map.singleton comp + +insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a +insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps + where + aux Nothing = Just a + aux (Just a') = Just $ a `mappend` a' + +-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' +-- as the neutral element when a 'Component' is present only in one. +zip :: (Monoid a, Monoid b) => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) +{- TODO/FIXME: Once we can expect containers>=0.5, switch to the more efficient version below: + +zip (ComponentDeps d1) (ComponentDeps d2) = + ComponentDeps $ + Map.mergeWithKey + (\_ a b -> Just (a,b)) + (fmap (\a -> (a, mempty))) + (fmap (\b -> (mempty, b))) + d1 d2 + +-} +zip (ComponentDeps d1) (ComponentDeps d2) = + ComponentDeps $ + Map.unionWith + mappend + (Map.map (\a -> (a, mempty)) d1) + (Map.map (\b -> (mempty, b)) d2) + + +-- | Keep only selected components (and their associated deps info). +filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a +filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps + +-- | ComponentDeps containing library dependencies only +fromLibraryDeps :: a -> ComponentDeps a +fromLibraryDeps = singleton ComponentLib + +-- | ComponentDeps containing setup dependencies only. +fromSetupDeps :: a -> ComponentDeps a +fromSetupDeps = singleton ComponentSetup + +-- | ComponentDeps for installed packages. +-- +-- We assume that installed packages only record their library dependencies. +fromInstalled :: a -> ComponentDeps a +fromInstalled = fromLibraryDeps + +{------------------------------------------------------------------------------- + Deconstruction +-------------------------------------------------------------------------------} + +toList :: ComponentDeps a -> [ComponentDep a] +toList = Map.toList . unComponentDeps + +-- | All dependencies of a package. +-- +-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more +-- obvious than a use of 'fold', and moreover this avoids introducing lots of +-- @#ifdef@s for 7.10 just for the use of 'fold'. +flatDeps :: Monoid a => ComponentDeps a -> a +flatDeps = fold + +-- | All dependencies except the setup dependencies. +-- +-- Prior to the introduction of setup dependencies in version 1.24 this +-- would have been _all_ dependencies. +nonSetupDeps :: Monoid a => ComponentDeps a -> a +nonSetupDeps = select (/= ComponentSetup) + +-- | Library dependencies proper only. (Includes dependencies +-- of internal libraries.) +libraryDeps :: Monoid a => ComponentDeps a -> a +libraryDeps = select (\c -> case c of ComponentSubLib _ -> True + ComponentLib -> True + _ -> False) + +-- | Setup dependencies. +setupDeps :: Monoid a => ComponentDeps a -> a +setupDeps = select (== ComponentSetup) + +-- | Select dependencies satisfying a given predicate. +select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a +select p = foldMap snd . filter (p . fst) . toList diff --git a/Distribution/Solver/Types/ConstraintSource.hs b/Distribution/Solver/Types/ConstraintSource.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/ConstraintSource.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) + , showConstraintSource + ) where + +import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary(..)) + +-- | Source of a 'PackageConstraint'. +data ConstraintSource = + + -- | Main config file, which is ~/.cabal/config by default. + ConstraintSourceMainConfig FilePath + + -- | Local cabal.project file + | ConstraintSourceProjectConfig FilePath + + -- | Sandbox config file, which is ./cabal.sandbox.config by default. + | ConstraintSourceSandboxConfig FilePath + + -- | User config file, which is ./cabal.config by default. + | ConstraintSourceUserConfig FilePath + + -- | Flag specified on the command line. + | ConstraintSourceCommandlineFlag + + -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ + -- implies @package==0.1.0.0@. + | ConstraintSourceUserTarget + + -- | Internal requirement to use installed versions of packages like ghc-prim. + | ConstraintSourceNonUpgradeablePackage + + -- | Internal requirement to use the add-source version of a package when that + -- version is installed and the source is modified. + | ConstraintSourceModifiedAddSourceDep + + -- | Internal constraint used by @cabal freeze@. + | ConstraintSourceFreeze + + -- | Constraint specified by a config file, a command line flag, or a user + -- target, when a more specific source is not known. + | ConstraintSourceConfigFlagOrTarget + + -- | The source of the constraint is not specified. + | ConstraintSourceUnknown + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a minimum lower bound on Cabal + | ConstraintSetupCabalMinVersion + deriving (Eq, Show, Generic) + +instance Binary ConstraintSource + +-- | Description of a 'ConstraintSource'. +showConstraintSource :: ConstraintSource -> String +showConstraintSource (ConstraintSourceMainConfig path) = + "main config " ++ path +showConstraintSource (ConstraintSourceProjectConfig path) = + "project config " ++ path +showConstraintSource (ConstraintSourceSandboxConfig path) = + "sandbox config " ++ path +showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path +showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" +showConstraintSource ConstraintSourceUserTarget = "user target" +showConstraintSource ConstraintSourceNonUpgradeablePackage = + "non-upgradeable package" +showConstraintSource ConstraintSourceModifiedAddSourceDep = + "modified add-source dependency" +showConstraintSource ConstraintSourceFreeze = "cabal freeze" +showConstraintSource ConstraintSourceConfigFlagOrTarget = + "config file, command line flag, or user target" +showConstraintSource ConstraintSourceUnknown = "unknown source" +showConstraintSource ConstraintSetupCabalMinVersion = + "minimum version of Cabal used by Setup.hs" diff --git a/Distribution/Solver/Types/DependencyResolver.hs b/Distribution/Solver/Types/DependencyResolver.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/DependencyResolver.hs @@ -0,0 +1,36 @@ +module Distribution.Solver.Types.DependencyResolver + ( DependencyResolver + ) where + +import Data.Set (Set) + +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SourcePackage + +import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) +import Distribution.Package ( PackageName ) +import Distribution.Compiler ( CompilerInfo ) +import Distribution.System ( Platform ) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver loc = Platform + -> CompilerInfo + -> InstalledPackageIndex + -> PackageIndex (SourcePackage loc) + -> PkgConfigDb + -> (PackageName -> PackagePreferences) + -> [LabeledPackageConstraint] + -> Set PackageName + -> Progress String String [ResolverPackage loc] diff --git a/Distribution/Solver/Types/Flag.hs b/Distribution/Solver/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/Flag.hs @@ -0,0 +1,6 @@ +module Distribution.Solver.Types.Flag + ( FlagType(..) + ) where + +data FlagType = Manual | Automatic + deriving (Eq, Show) diff --git a/Distribution/Solver/Types/InstSolverPackage.hs b/Distribution/Solver/Types/InstSolverPackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/InstSolverPackage.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.InstSolverPackage + ( InstSolverPackage(..) + ) where + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.SolverId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.MungedPackageName +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import GHC.Generics (Generic) + +-- | An 'InstSolverPackage' is a pre-existing installed pacakge +-- specified by the dependency solver. +data InstSolverPackage = InstSolverPackage { + instSolverPkgIPI :: InstalledPackageInfo, + instSolverPkgLibDeps :: ComponentDeps [SolverId], + instSolverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary InstSolverPackage + +instance Package InstSolverPackage where + packageId i = + -- HACK! See Note [Index conversion with internal libraries] + let MungedPackageId mpn v = mungedId i + in PackageIdentifier (mkPackageName (unMungedPackageName mpn)) v + +instance HasMungedPackageId InstSolverPackage where + mungedId = mungedId . instSolverPkgIPI + +instance HasUnitId InstSolverPackage where + installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/Distribution/Solver/Types/InstalledPreference.hs b/Distribution/Solver/Types/InstalledPreference.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/InstalledPreference.hs @@ -0,0 +1,9 @@ +module Distribution.Solver.Types.InstalledPreference + ( InstalledPreference(..), + ) where + +-- | Whether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest + deriving Show diff --git a/Distribution/Solver/Types/LabeledPackageConstraint.hs b/Distribution/Solver/Types/LabeledPackageConstraint.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -0,0 +1,14 @@ +module Distribution.Solver.Types.LabeledPackageConstraint + ( LabeledPackageConstraint(..) + , unlabelPackageConstraint + ) where + +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.PackageConstraint + +-- | 'PackageConstraint' labeled with its source. +data LabeledPackageConstraint + = LabeledPackageConstraint PackageConstraint ConstraintSource + +unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint +unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/Distribution/Solver/Types/OptionalStanza.hs b/Distribution/Solver/Types/OptionalStanza.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/OptionalStanza.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Solver.Types.OptionalStanza + ( OptionalStanza(..) + , showStanza + , enableStanzas + ) where + +import GHC.Generics (Generic) +import Data.Typeable +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Types.ComponentRequestedSpec + (ComponentRequestedSpec(..), defaultComponentRequestedSpec) +import Data.List (foldl') + +data OptionalStanza + = TestStanzas + | BenchStanzas + deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) + +-- | String representation of an OptionalStanza. +showStanza :: OptionalStanza -> String +showStanza TestStanzas = "test" +showStanza BenchStanzas = "bench" + +-- | Convert a list of 'OptionalStanza' into the corresponding +-- 'ComponentRequestedSpec' which records what components are enabled. +enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec +enableStanzas = foldl' addStanza defaultComponentRequestedSpec + where + addStanza enabled TestStanzas = enabled { testsRequested = True } + addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } + +instance Binary OptionalStanza diff --git a/Distribution/Solver/Types/PackageConstraint.hs b/Distribution/Solver/Types/PackageConstraint.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PackageConstraint.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +module Distribution.Solver.Types.PackageConstraint ( + ConstraintScope(..), + scopeToplevel, + scopeToPackageName, + constraintScopeMatches, + PackageProperty(..), + dispPackageProperty, + PackageConstraint(..), + dispPackageConstraint, + showPackageConstraint, + packageConstraintToDependency + ) where + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Version (VersionRange, simplifyVersionRange) + +import Distribution.Client.Compat.Prelude ((<<>>)) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath + +import Distribution.Text (disp, flatStyle) +import GHC.Generics (Generic) +import Text.PrettyPrint ((<+>)) +import qualified Text.PrettyPrint as Disp + + +-- | Determines to what packages and in what contexts a +-- constraint applies. +data ConstraintScope + -- | The package with the specified name and qualifier. + = ScopeQualified Qualifier PackageName + -- | The package with the specified name when it has a + -- setup qualifier. + | ScopeAnySetupQualifier PackageName + -- | The package with the specified name regardless of + -- qualifier. + | ScopeAnyQualifier PackageName + deriving (Eq, Show) + +-- | Constructor for a common use case: the constraint applies to +-- the package with the specified name when that package is a +-- top-level dependency in the default namespace. +scopeToplevel :: PackageName -> ConstraintScope +scopeToplevel = ScopeQualified QualToplevel + +-- | Returns the package name associated with a constraint scope. +scopeToPackageName :: ConstraintScope -> PackageName +scopeToPackageName (ScopeQualified _ pn) = pn +scopeToPackageName (ScopeAnySetupQualifier pn) = pn +scopeToPackageName (ScopeAnyQualifier pn) = pn + +constraintScopeMatches :: ConstraintScope -> QPN -> Bool +constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = + q == q' && pn == pn' +constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = + let setup (PackagePath _ (QualSetup _)) = True + setup _ = False + in setup pp && pn == pn' +constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' + +-- | Pretty-prints a constraint scope. +dispConstraintScope :: ConstraintScope -> Disp.Doc +dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn +dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn +dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] + deriving (Eq, Show, Generic) + +instance Binary PackageProperty + +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = disp verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a scope plus a property +-- that must hold for all packages within that scope. +data PackageConstraint = PackageConstraint ConstraintScope PackageProperty + deriving (Eq, Show) + +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint scope prop) = + dispConstraintScope scope <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). +-- +showPackageConstraint :: PackageConstraint -> String +showPackageConstraint pc@(PackageConstraint scope prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + where + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id + +-- | Lossily convert a 'PackageConstraint' to a 'Dependency'. +packageConstraintToDependency :: PackageConstraint -> Maybe Dependency +packageConstraintToDependency (PackageConstraint scope prop) = toDep prop + where + toDep (PackagePropertyVersion vr) = + Just $ Dependency (scopeToPackageName scope) vr + toDep (PackagePropertyInstalled) = Nothing + toDep (PackagePropertySource) = Nothing + toDep (PackagePropertyFlags _) = Nothing + toDep (PackagePropertyStanzas _) = Nothing diff --git a/Distribution/Solver/Types/PackageFixedDeps.hs b/Distribution/Solver/Types/PackageFixedDeps.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PackageFixedDeps.hs @@ -0,0 +1,23 @@ +module Distribution.Solver.Types.PackageFixedDeps + ( PackageFixedDeps(..) + ) where + +import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) +import Distribution.Package + ( Package(..), UnitId, installedDepends) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import qualified Distribution.Solver.Types.ComponentDeps as CD + +-- | Subclass of packages that have specific versioned dependencies. +-- +-- So for example a not-yet-configured package has dependencies on version +-- ranges, not specific versions. A configured or an already installed package +-- depends on exact versions. Some operations or data structures (like +-- dependency graphs) only make sense on this subclass of package types. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> ComponentDeps [UnitId] + +instance PackageFixedDeps InstalledPackageInfo where + depends pkg = CD.fromInstalled (installedDepends pkg) + diff --git a/Distribution/Solver/Types/PackageIndex.hs b/Distribution/Solver/Types/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PackageIndex.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Solver.Types.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + elemByPackageId, + elemByPackageName, + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (lookup) + +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.List (groupBy, isInfixOf) + +import Distribution.Package + ( PackageName, unPackageName, PackageIdentifier(..) + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency +import Distribution.Version + ( withinRange ) +import Distribution.Simple.Utils + ( lowercase, comparing ) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched efficiently by package name and version. +-- +newtype PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Eq, Show, Read, Functor, Generic) +--FIXME: the Functor instance here relies on no package id changes + +instance Package pkg => Semigroup (PackageIndex pkg) where + (<>) = merge + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex Map.empty + mappend = (<>) + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +instance Binary pkg => Binary (PackageIndex pkg) + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg + -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg + -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg + -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg + -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool +elemByPackageId index = isJust . lookupPackageId index + +elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool +elemByPackageName index = not . null . lookupPackageName index + + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier + -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByName (PackageIndex m) name = + [ pkgs + | pkgs@(pname,_) <- Map.toList m + , lowercase (unPackageName pname) == lname ] + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkgs + | pkgs@(pname, _) <- Map.toList m + , lsearchterm `isInfixOf` lowercase (unPackageName pname) ] + where + lsearchterm = lowercase searchterm diff --git a/Distribution/Solver/Types/PackagePath.hs b/Distribution/Solver/Types/PackagePath.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PackagePath.hs @@ -0,0 +1,103 @@ +module Distribution.Solver.Types.PackagePath + ( PackagePath(..) + , Namespace(..) + , Qualifier(..) + , dispQualifier + , Qualified(..) + , QPN + , dispQPN + , showQPN + ) where + +import Distribution.Package +import Distribution.Text +import qualified Text.PrettyPrint as Disp +import Distribution.Client.Compat.Prelude ((<<>>)) + +-- | A package path consists of a namespace and a package path inside that +-- namespace. +data PackagePath = PackagePath Namespace Qualifier + deriving (Eq, Ord, Show) + +-- | Top-level namespace +-- +-- Package choices in different namespaces are considered completely independent +-- by the solver. +data Namespace = + -- | The default namespace + DefaultNamespace + + -- | Independent namespace + -- + -- For now we just number these (rather than giving them more structure). + | Independent Int + deriving (Eq, Ord, Show) + +-- | Pretty-prints a namespace. The result is either empty or +-- ends in a period, so it can be prepended onto a qualifier. +dispNamespace :: Namespace -> Disp.Doc +dispNamespace DefaultNamespace = Disp.empty +dispNamespace (Independent i) = Disp.int i <<>> Disp.text "." + +-- | Qualifier of a package within a namespace (see 'PackagePath') +data Qualifier = + -- | Top-level dependency in this namespace + QualToplevel + + -- | Any dependency on base is considered independent + -- + -- This makes it possible to have base shims. + | QualBase PackageName + + -- | Setup dependency + -- + -- By rights setup dependencies ought to be nestable; after all, the setup + -- dependencies of a package might themselves have setup dependencies, which + -- are independent from everything else. However, this very quickly leads to + -- infinite search trees in the solver. Therefore we limit ourselves to + -- a single qualifier (within a given namespace). + | QualSetup PackageName + + -- | If we depend on an executable from a package (via + -- @build-tools@), we should solve for the dependencies of that + -- package separately (since we're not going to actually try to + -- link it.) We qualify for EACH package separately; e.g., + -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on + -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that + -- would require a consistent dependency resolution for all + -- of the depended upon executables from a package; if we + -- tracked only @pn2@, that would require us to pick only one + -- version of an executable over the entire install plan.) + | QualExe PackageName PackageName + deriving (Eq, Ord, Show) + +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. +-- +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- is the qualifier and @"base"@ is the actual dependency (which, for the +-- 'Base' qualifier, will always be @base@). +dispQualifier :: Qualifier -> Disp.Doc +dispQualifier QualToplevel = Disp.empty +dispQualifier (QualSetup pn) = disp pn <<>> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>> + disp pn2 <<>> Disp.text ":exe." +dispQualifier (QualBase pn) = disp pn <<>> Disp.text "." + +-- | A qualified entity. Pairs a package path with the entity. +data Qualified a = Q PackagePath a + deriving (Eq, Ord, Show) + +-- | Qualified package name. +type QPN = Qualified PackageName + +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> disp pn + +-- | String representation of a qualified package name. +showQPN :: QPN -> String +showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/Distribution/Solver/Types/PackagePreferences.hs b/Distribution/Solver/Types/PackagePreferences.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PackagePreferences.hs @@ -0,0 +1,22 @@ +module Distribution.Solver.Types.PackagePreferences + ( PackagePreferences(..) + ) where + +import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.OptionalStanza +import Distribution.Version (VersionRange) + +-- | Per-package preferences on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- an 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also has (possibly multiple) +-- 'PackageVersionPreference's which are suggested constraints on the version +-- number. The resolver should try to use package versions that satisfy +-- the maximum number of the suggested version constraints. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences [VersionRange] + InstalledPreference + [OptionalStanza] diff --git a/Distribution/Solver/Types/PkgConfigDb.hs b/Distribution/Solver/Types/PkgConfigDb.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/PkgConfigDb.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Solver.Types.PkgConfigDb +-- Copyright : (c) Iñaki García Etxebarria 2016 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Read the list of packages available to pkg-config. +----------------------------------------------------------------------------- +module Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb + , readPkgConfigDb + , pkgConfigDbFromList + , pkgConfigPkgIsPresent + , pkgConfigDbPkgVersion + , getPkgConfigDbDirs + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Control.Exception (IOException, handle) +import qualified Data.Map as M +import Data.Version (parseVersion) +import Text.ParserCombinators.ReadP (readP_to_S) +import System.FilePath (splitSearchPath) + +import Distribution.Package + ( PkgconfigName, mkPkgconfigName ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Version + ( Version, mkVersion', VersionRange, withinRange ) + +import Distribution.Compat.Environment + ( lookupEnv ) +import Distribution.Simple.Program + ( ProgramDb, pkgConfigProgram, getProgramOutput, requireProgram ) +import Distribution.Simple.Utils + ( info ) + +-- | The list of packages installed in the system visible to +-- @pkg-config@. This is an opaque datatype, to be constructed with +-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. +data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe Version)) + -- ^ If an entry is `Nothing`, this means that the + -- package seems to be present, but we don't know the + -- exact version (because parsing of the version + -- number failed). + | NoPkgConfigDb + -- ^ For when we could not run pkg-config successfully. + deriving (Show, Generic, Typeable) + +instance Binary PkgConfigDb + +-- | Query pkg-config for the list of installed packages, together +-- with their versions. Return a `PkgConfigDb` encapsulating this +-- information. +readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb +readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do + (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig + ("--modversion" : pkgNames) + (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = do + info verbosity ("Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ show e) + return NoPkgConfigDb + +-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. +pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb +pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs + where + convert :: (String, String) -> (PkgconfigName, Maybe Version) + convert (n,vs) = (mkPkgconfigName n, + case (reverse . readP_to_S parseVersion) vs of + (v, "") : _ -> Just (mkVersion' v) + _ -> Nothing -- Version not (fully) + -- understood. + ) + +-- | Check whether a given package range is satisfiable in the given +-- @pkg-config@ database. +pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> VersionRange -> Bool +pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = + case M.lookup pn db of + Nothing -> False -- Package not present in the DB. + Just Nothing -> True -- Package present, but version unknown. + Just (Just v) -> withinRange v vr +-- If we could not read the pkg-config database successfully we allow +-- the check to succeed. The plan found by the solver may fail to be +-- executed later on, but we have no grounds for rejecting the plan at +-- this stage. +pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True + + +-- | Query the version of a package in the @pkg-config@ database. +-- @Nothing@ indicates the package is not in the database, while +-- @Just Nothing@ indicates that the package is in the database, +-- but its version is not known. +pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe Version) +pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db +-- NB: Since the solver allows solving to succeed if there is +-- NoPkgConfigDb, we should report that we *guess* that there +-- is a matching pkg-config configuration, but that we just +-- don't know about it. +pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing + + +-- | Query pkg-config for the locations of pkg-config's package files. Use this +-- to monitor for changes in the pkg-config DB. +-- +getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] +getPkgConfigDbDirs verbosity progdb = + (++) <$> getEnvPath <*> getDefPath + where + -- According to @man pkg-config@: + -- + -- PKG_CONFIG_PATH + -- A colon-separated (on Windows, semicolon-separated) list of directories + -- to search for .pc files. The default directory will always be searched + -- after searching the path + -- + getEnvPath = maybe [] parseSearchPath + <$> lookupEnv "PKG_CONFIG_PATH" + + -- Again according to @man pkg-config@: + -- + -- pkg-config can be used to query itself for the default search path, + -- version number and other information, for instance using: + -- + -- > pkg-config --variable pc_path pkg-config + -- + getDefPath = handle ioErrorHandler $ do + (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb + parseSearchPath <$> + getProgramOutput verbosity pkgConfig + ["--variable", "pc_path", "pkg-config"] + + parseSearchPath str = + case lines str of + [p] | not (null p) -> splitSearchPath p + _ -> [] + + ioErrorHandler :: IOException -> IO [FilePath] + ioErrorHandler _e = return [] diff --git a/Distribution/Solver/Types/Progress.hs b/Distribution/Solver/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/Progress.hs @@ -0,0 +1,49 @@ +module Distribution.Solver.Types.Progress + ( Progress(..) + , foldProgress + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (fail) + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- result which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- This Functor instance works around a bug in GHC 7.6.3. +-- See https://ghc.haskell.org/trac/ghc/ticket/7436#comment:6. +-- The derived functor instance caused a space leak in the solver. +instance Functor (Progress step fail) where + fmap f (Step s p) = Step s (fmap f p) + fmap _ (Fail x) = Fail x + fmap f (Done r) = Done (f r) + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Monad (Progress step fail) where + return = pure + p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/Distribution/Solver/Types/ResolverPackage.hs b/Distribution/Solver/Types/ResolverPackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/ResolverPackage.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.ResolverPackage + ( ResolverPackage(..) + , resolverPackageLibDeps + , resolverPackageExeDeps + ) where + +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import qualified Distribution.Solver.Types.ComponentDeps as CD + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Package (Package(..), HasUnitId(..)) +import Distribution.Simple.Utils (ordNub) +import GHC.Generics (Generic) + +-- | The dependency resolver picks either pre-existing installed packages +-- or it picks source packages along with package configuration. +-- +-- This is like the 'InstallPlan.PlanPackage' but with fewer cases. +-- +data ResolverPackage loc = PreExisting InstSolverPackage + | Configured (SolverPackage loc) + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (ResolverPackage loc) + +instance Package (ResolverPackage loc) where + packageId (PreExisting ipkg) = packageId ipkg + packageId (Configured spkg) = packageId spkg + +resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg +resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg + +resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg +resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg + +instance IsNode (ResolverPackage loc) where + type Key (ResolverPackage loc) = SolverId + nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) + nodeKey (Configured spkg) = PlannedId (packageId spkg) + -- Use dependencies for ALL components + nodeNeighbors pkg = + ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ + CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/Distribution/Solver/Types/Settings.hs b/Distribution/Solver/Types/Settings.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/Settings.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Solver.Types.Settings + ( ReorderGoals(..) + , IndependentGoals(..) + , AvoidReinstalls(..) + , ShadowPkgs(..) + , StrongFlags(..) + , AllowBootLibInstalls(..) + , EnableBackjumping(..) + , CountConflicts(..) + , SolveExecutables(..) + ) where + +import Distribution.Simple.Setup ( BooleanFlag(..) ) +import Distribution.Compat.Binary (Binary(..)) +import GHC.Generics (Generic) + +newtype ReorderGoals = ReorderGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype CountConflicts = CountConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype IndependentGoals = IndependentGoals Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AvoidReinstalls = AvoidReinstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype ShadowPkgs = ShadowPkgs Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype StrongFlags = StrongFlags Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype AllowBootLibInstalls = AllowBootLibInstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype EnableBackjumping = EnableBackjumping Bool + deriving (BooleanFlag, Eq, Generic, Show) + +newtype SolveExecutables = SolveExecutables Bool + deriving (BooleanFlag, Eq, Generic, Show) + +instance Binary ReorderGoals +instance Binary CountConflicts +instance Binary IndependentGoals +instance Binary AvoidReinstalls +instance Binary ShadowPkgs +instance Binary StrongFlags +instance Binary AllowBootLibInstalls +instance Binary SolveExecutables diff --git a/Distribution/Solver/Types/SolverId.hs b/Distribution/Solver/Types/SolverId.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/SolverId.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverId + ( SolverId(..) + ) + +where + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package (PackageId, Package(..), UnitId) +import GHC.Generics (Generic) + +-- | The solver can produce references to existing packages or +-- packages we plan to install. Unlike 'ConfiguredId' we don't +-- yet know the 'UnitId' for planned packages, because it's +-- not the solver's job to compute them. +-- +data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } + | PlannedId { solverSrcId :: PackageId } + deriving (Eq, Ord, Generic) + +instance Binary SolverId + +instance Show SolverId where + show = show . solverSrcId + +instance Package SolverId where + packageId = solverSrcId diff --git a/Distribution/Solver/Types/SolverPackage.hs b/Distribution/Solver/Types/SolverPackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/SolverPackage.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.SolverPackage + ( SolverPackage(..) + ) where + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package ( Package(..) ) +import Distribution.PackageDescription ( FlagAssignment ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SourcePackage +import GHC.Generics (Generic) + +-- | A 'SolverPackage' is a package specified by the dependency solver. +-- It will get elaborated into a 'ConfiguredPackage' or even an +-- 'ElaboratedConfiguredPackage'. +-- +-- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', +-- but for symmetry we have the parameter. (Maybe it can be removed.) +-- +data SolverPackage loc = SolverPackage { + solverPkgSource :: SourcePackage loc, + solverPkgFlags :: FlagAssignment, + solverPkgStanzas :: [OptionalStanza], + solverPkgLibDeps :: ComponentDeps [SolverId], + solverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary loc => Binary (SolverPackage loc) + +instance Package (SolverPackage loc) where + packageId = packageId . solverPkgSource diff --git a/Distribution/Solver/Types/SourcePackage.hs b/Distribution/Solver/Types/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/SourcePackage.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Solver.Types.SourcePackage + ( PackageDescriptionOverride + , SourcePackage(..) + ) where + +import Distribution.Package + ( PackageId, Package(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..) ) + +import Data.ByteString.Lazy (ByteString) +import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary(..)) +import Data.Typeable + +-- | A package description along with the location of the package sources. +-- +data SourcePackage loc = SourcePackage { + packageInfoId :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: loc, + packageDescrOverride :: PackageDescriptionOverride + } + deriving (Eq, Show, Generic, Typeable) + +instance (Binary loc) => Binary (SourcePackage loc) + +instance Package (SourcePackage a) where packageId = packageInfoId + +-- | We sometimes need to override the .cabal file in the tarball with +-- the newer one from the package index. +type PackageDescriptionOverride = Maybe ByteString diff --git a/Distribution/Solver/Types/Variable.hs b/Distribution/Solver/Types/Variable.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Types/Variable.hs @@ -0,0 +1,14 @@ +module Distribution.Solver.Types.Variable where + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.PackageDescription (FlagName) + +-- | Variables used by the dependency solver. This type is similar to the +-- internal 'Var' type, except that flags and stanzas are associated with +-- package names instead of package instances. +data Variable qpn = + PackageVar qpn + | FlagVar qpn FlagName + | StanzaVar qpn OptionalStanza + deriving Eq diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,5 @@ -Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, - Lemmih, Paolo Martini, Don Stewart, - Duncan Coutts +Copyright (c) 2003-2017, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -19,1305 +19,1206 @@ ( GlobalFlags(..), globalCommand, withRepoContext , ConfigFlags(..) , ConfigExFlags(..), defaultConfigExFlags, configureExCommand - , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , buildCommand, replCommand, testCommand, benchmarkCommand - , InstallFlags(..), defaultInstallFlags - , installCommand, upgradeCommand, uninstallCommand - , FetchFlags(..), fetchCommand - , FreezeFlags(..), freezeCommand - , genBoundsCommand - , GetFlags(..), getCommand, unpackCommand - , checkCommand - , formatCommand - , updateCommand - , ListFlags(..), listCommand - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand - , runCommand - , InitFlags(initVerbosity), initCommand - , SDistFlags(..), SDistExFlags(..), sdistCommand - , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand - , ActAsSetupFlags(..), actAsSetupCommand - , SandboxFlags(..), sandboxCommand - , ExecFlags(..), execCommand - , UserConfigFlags(..), userConfigCommand - , reportCommand - , manpageCommand - ) -import Distribution.Simple.Setup - ( HaddockFlags(..), haddockCommand, defaultHaddockFlags - , HscolourFlags(..), hscolourCommand - , ReplFlags(..) - , CopyFlags(..), copyCommand - , RegisterFlags(..), registerCommand - , CleanFlags(..), cleanCommand - , TestFlags(..), BenchmarkFlags(..) - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag - , configAbsolutePaths - ) - -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff - , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) -import Distribution.Client.Targets - ( readUserTargets ) -import qualified Distribution.Client.List as List - ( list, info ) - -import qualified Distribution.Client.CmdConfigure as CmdConfigure -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl - -import Distribution.Client.Install (install) -import Distribution.Client.Configure (configure) -import Distribution.Client.Update (update) -import Distribution.Client.Exec (exec) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Freeze (freeze) -import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) -import qualified Distribution.Client.Upload as Upload -import Distribution.Client.Run (run, splitRunArgs) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Get (get) -import Distribution.Client.Sandbox (sandboxInit - ,sandboxAddSource - ,sandboxDelete - ,sandboxDeleteSource - ,sandboxListSources - ,sandboxHcPkg - ,dumpPackageEnvironment - - ,getSandboxConfigFilePath - ,loadConfigOrSandboxConfig - ,findSavedDistPref - ,initPackageDBIfNeeded - ,maybeWithSandboxDirOnSearchPath - ,maybeWithSandboxPackageInfo - ,WereDepsReinstalled(..) - ,maybeReinstallAddSourceDeps - ,tryGetIndexFilePath - ,sandboxBuildDir - ,updateSandboxConfigFileFlag - ,updateInstallDirs - - ,configCompilerAux' - ,getPersistOrConfigCompiler - ,configPackageDB') -import Distribution.Client.Sandbox.PackageEnvironment - (setPackageDB - ,userPackageEnvironmentFile) -import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) -import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) -import Distribution.Client.Tar (createTarGzFile) -import Distribution.Client.Types (Password (..)) -import Distribution.Client.Init (initCabal) -import Distribution.Client.Manpage (manpage) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import Distribution.Client.Utils (determineNumJobs -#if defined(mingw32_HOST_OS) - ,relaxEncodingErrors -#endif - ,existsAndIsMoreRecentThan) - -import Distribution.Package (packageId) -import Distribution.PackageDescription - ( BuildType(..), Executable(..), buildable ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import qualified Distribution.Simple as Simple -import qualified Distribution.Make as Make -import Distribution.Simple.Build - ( startInterpreter ) -import Distribution.Simple.Command - ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) - , CommandType(..), commandsRun, commandAddAction, hiddenCommand - , commandFromSpec) -import Distribution.Simple.Compiler - ( Compiler(..) ) -import Distribution.Simple.Configure - ( checkPersistBuildConfigOutdated, configCompilerAuxEx - , ConfigStateFileError(..), localBuildInfoFile - , getPersistBuildConfig, tryGetPersistBuildConfig ) -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Program (defaultProgramConfiguration - ,configureAllKnownPrograms - ,simpleProgramInvocation - ,getProgramInvocationOutput) -import Distribution.Simple.Program.Db (reconfigurePrograms) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Utils - ( cabalVersion, die, notice, info, topHandler - , findPackageDesc, tryFindPackageDesc ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import qualified Paths_cabal_install (version) - -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>)) -import System.IO ( BufferMode(LineBuffering), hSetBuffering -#ifdef mingw32_HOST_OS - , stderr -#endif - , stdout ) -import System.Directory (doesFileExist, getCurrentDirectory) -import Data.List (intercalate) -import Data.Maybe (listToMaybe) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid(..)) -import Control.Applicative (pure, (<$>)) -#endif -import Control.Exception (SomeException(..), try) -import Control.Monad (when, unless, void) - --- | Entry point --- -main :: IO () -main = do - -- Enable line buffering so that we can get fast feedback even when piped. - -- This is especially important for CI and build systems. - hSetBuffering stdout LineBuffering - -- The default locale encoding for Windows CLI is not UTF-8 and printing - -- Unicode characters to it will fail unless we relax the handling of encoding - -- errors when writing to stderr and stdout. -#ifdef mingw32_HOST_OS - relaxEncodingErrors stdout - relaxEncodingErrors stderr -#endif - getArgs >>= mainWorker - -mainWorker :: [String] -> IO () -mainWorker args = topHandler $ - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> do - globalFlags' <- updateSandboxConfigFileFlag globalFlags - action globalFlags' - - where - printCommandHelp help = do - pname <- getProgName - putStr (help pname) - printGlobalHelp help = do - pname <- getProgName - configFile <- defaultConfigFile - putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" - exists <- doesFileExist configFile - when (not exists) $ - putStrLn $ "This file will be generated with sensible " - ++ "defaults if you run 'cabal update'." - printOptionsList = putStr . unlines - printErrors errs = die $ intercalate "\n" errs - printNumericVersion = putStrLn $ display Paths_cabal_install.version - printVersion = putStrLn $ "cabal-install version " - ++ display Paths_cabal_install.version - ++ "\ncompiled using version " - ++ display cabalVersion - ++ " of the Cabal library " - - commands = map commandFromSpec commandSpecs - commandSpecs = - [ regularCmd installCommand installAction - , regularCmd updateCommand updateAction - , regularCmd listCommand listAction - , regularCmd infoCommand infoAction - , regularCmd fetchCommand fetchAction - , regularCmd freezeCommand freezeAction - , regularCmd getCommand getAction - , hiddenCmd unpackCommand unpackAction - , regularCmd checkCommand checkAction - , regularCmd sdistCommand sdistAction - , regularCmd uploadCommand uploadAction - , regularCmd reportCommand reportAction - , regularCmd runCommand runAction - , regularCmd initCommand initAction - , regularCmd configureExCommand configureAction - , regularCmd buildCommand buildAction - , regularCmd replCommand replAction - , regularCmd sandboxCommand sandboxAction - , regularCmd haddockCommand haddockAction - , regularCmd execCommand execAction - , regularCmd userConfigCommand userConfigAction - , regularCmd cleanCommand cleanAction - , regularCmd genBoundsCommand genBoundsAction - , wrapperCmd copyCommand copyVerbosity copyDistPref - , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , wrapperCmd registerCommand regVerbosity regDistPref - , regularCmd testCommand testAction - , regularCmd benchmarkCommand benchmarkAction - , hiddenCmd uninstallCommand uninstallAction - , hiddenCmd formatCommand formatAction - , hiddenCmd upgradeCommand upgradeAction - , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction - , hiddenCmd actAsSetupCommand actAsSetupAction - , hiddenCmd manpageCommand (manpageAction commandSpecs) - - , hiddenCmd installCommand { commandName = "new-configure" } - CmdConfigure.configureAction - , hiddenCmd installCommand { commandName = "new-build" } - CmdBuild.buildAction - , hiddenCmd installCommand { commandName = "new-repl" } - CmdRepl.replAction - ] - -type Action = GlobalFlags -> IO () - -regularCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) action) NormalCommand - -hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -hiddenCmd ui action = - CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) - HiddenCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) - -> (flags -> Flag String) -> CommandSpec Action -wrapperCmd ui verbosity distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand - -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command Action -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) extraArgs - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - - (useSandbox, config) <- fmap - (updateInstallDirs (configUserInstall configFlags)) - (loadConfigOrSandboxConfig verbosity globalFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, conf) <- configCompilerAuxEx configFlags' - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - let configFlags'' = case useSandbox of - NoSandbox -> configFlags' - (UseSandbox sandboxDir) -> setPackageDB sandboxDir - comp platform configFlags' - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp conf - -- NOTE: We do not write the new sandbox package DB location to - -- 'cabal.sandbox.config' here because 'configure -w' must not affect - -- subsequent 'install' (for UI compatibility with non-sandboxed mode). - - indexFile <- tryGetIndexFilePath config - maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile - (compilerId comp) platform - - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - configure verbosity - (configPackageDB' configFlags'') - repoContext - comp platform conf configFlags'' configExFlags' extraArgs - -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - -- Calls 'configureAction' to do the real work, so nothing special has to be - -- done to support sandboxes. - (useSandbox, config, distPref) <- reconfigure verbosity - (buildDistPref buildFlags) - mempty [] globalFlags noAddSource - (buildNumJobs buildFlags) (const Nothing) - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags extraArgs - - --- | Actually do the work of building the package. This is separate from --- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke --- 'reconfigure' twice. -build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () -build verbosity config distPref buildFlags extraArgs = - setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progConf) mkBuildFlags extraArgs - where - progConf = defaultProgramConfiguration - setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - - mkBuildFlags version = filterBuildFlags version config buildFlags' - buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref - } - --- | Make sure that we don't pass new flags to setup scripts compiled against --- old versions of Cabal. -filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags -filterBuildFlags version config buildFlags - | version >= Version [1,19,1] [] = buildFlags_latest - -- Cabal < 1.19.1 doesn't support 'build -j'. - | otherwise = buildFlags_pre_1_19_1 - where - buildFlags_pre_1_19_1 = buildFlags { - buildNumJobs = NoFlag - } - buildFlags_latest = buildFlags { - -- Take the 'jobs' setting '~/.cabal/config' into account. - buildNumJobs = Flag . Just . determineNumJobs $ - (numJobsConfigFlag `mappend` numJobsCmdLineFlag) - } - numJobsConfigFlag = installNumJobs . savedInstallFlags $ config - numJobsCmdLineFlag = buildNumJobs buildFlags - - -replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action -replAction (replFlags, buildExFlags) extraArgs globalFlags = do - cwd <- getCurrentDirectory - pkgDesc <- findPackageDesc cwd - either (const onNoPkgDesc) (const onPkgDesc) pkgDesc - where - verbosity = fromFlagOrDefault normal (replVerbosity replFlags) - - -- There is a .cabal file in the current directory: start a REPL and load - -- the project's modules. - onPkgDesc = do - let noAddSource = case replReload replFlags of - Flag True -> SkipAddSourceDepsCheck - _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - -- Calls 'configureAction' to do the real work, so nothing special has to - -- be done to support sandboxes. - (useSandbox, _config, distPref) <- - reconfigure verbosity (replDistPref replFlags) - mempty [] globalFlags noAddSource NoFlag - (const Nothing) - let progConf = defaultProgramConfiguration - setupOptions = defaultSetupScriptOptions - { useCabalVersion = orLaterVersion $ Version [1,18,0] [] - , useDistPref = distPref - } - replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref - } - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - (Cabal.replCommand progConf) (const replFlags') extraArgs - - -- No .cabal file in the current directory: just start the REPL (possibly - -- using the sandbox package DB). - onNoPkgDesc = do - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - (comp, platform, programDb) <- configCompilerAux' configFlags - programDb' <- reconfigurePrograms verbosity - (replProgramPaths replFlags) - (replProgramArgs replFlags) - programDb - startInterpreter verbosity programDb' comp platform - (configPackageDB' configFlags) - --- | Re-configure the package in the current directory if needed. Deciding --- when to reconfigure and with which options is convoluted: --- --- If we are reconfiguring, we must always run @configure@ with the --- verbosity option we are given; however, that a previous configuration --- uses a different verbosity setting is not reason enough to reconfigure. --- --- The package should be configured to use the same \"dist\" prefix as --- given to the @build@ command, otherwise the build will probably --- fail. Not only does this determine the \"dist\" prefix setting if we --- need to reconfigure anyway, but an existing configuration should be --- invalidated if its \"dist\" prefix differs. --- --- If the package has never been configured (i.e., there is no --- LocalBuildInfo), we must configure first, using the default options. --- --- If the package has been configured, there will be a 'LocalBuildInfo'. --- If there no package description file, we assume that the --- 'PackageDescription' is up to date, though the configuration may need --- to be updated for other reasons (see above). If there is a package --- description file, and it has been modified since the 'LocalBuildInfo' --- was generated, then we need to reconfigure. --- --- The caller of this function may also have specific requirements --- regarding the flags the last configuration used. For example, --- 'testAction' requires that the package be configured with test suites --- enabled. The caller may pass the required settings to this function --- along with a function to check the validity of the saved 'ConfigFlags'; --- these required settings will be checked first upon determining that --- a previous configuration exists. -reconfigure :: Verbosity -- ^ Verbosity setting - -> Flag FilePath -- ^ \"dist\" prefix - -> ConfigFlags -- ^ Additional config flags to set. These flags - -- will be 'mappend'ed to the last used or - -- default 'ConfigFlags' as appropriate, so - -- this value should be 'mempty' with only the - -- required flags set. The required verbosity - -- and \"dist\" prefix flags will be set - -- automatically because they are always - -- required; therefore, it is not necessary to - -- set them here. - -> [String] -- ^ Extra arguments - -> GlobalFlags -- ^ Global flags - -> SkipAddSourceDepsCheck - -- ^ Should we skip the timestamp check for modified - -- add-source dependencies? - -> Flag (Maybe Int) - -- ^ -j flag for reinstalling add-source deps. - -> (ConfigFlags -> Maybe String) - -- ^ Check that the required flags are set in - -- the last used 'ConfigFlags'. If the required - -- flags are not set, provide a message to the - -- user explaining the reason for - -- reconfiguration. Because the correct \"dist\" - -- prefix setting is always required, it is checked - -- automatically; this function need not check - -- for it. - -> IO (UseSandbox, SavedConfig, FilePath) -reconfigure verbosity flagDistPref addConfigFlags extraArgs globalFlags - skipAddSourceDepsCheck numJobsFlag checkFlags = do - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config flagDistPref - eLbi <- tryGetPersistBuildConfig distPref - config' <- case eLbi of - Left err -> onNoBuildConfig (useSandbox, config) distPref err - Right lbi -> onBuildConfig (useSandbox, config) distPref lbi - return (useSandbox, config', distPref) - - where - - -- We couldn't load the saved package config file. - -- - -- If we're in a sandbox: add-source deps don't have to be reinstalled - -- (since we don't know the compiler & platform). - onNoBuildConfig :: (UseSandbox, SavedConfig) -> FilePath - -> ConfigStateFileError -> IO SavedConfig - onNoBuildConfig (_, config) distPref err = do - let msg = case err of - ConfigStateFileMissing -> "Package has never been configured." - ConfigStateFileNoParse -> "Saved package config file seems " - ++ "to be corrupt." - _ -> show err - case err of - -- Note: the build config could have been generated by a custom setup - -- script built against a different Cabal version, so it's crucial that - -- we ignore the bad version error here. - ConfigStateFileBadVersion _ _ _ -> info verbosity msg - _ -> do - let distVerbFlags = mempty - { configVerbosity = toFlag verbosity - , configDistPref = toFlag distPref - } - defaultFlags = mappend addConfigFlags distVerbFlags - notice verbosity - $ msg ++ " Configuring with default flags." ++ configureManually - configureAction (defaultFlags, defaultConfigExFlags) - extraArgs globalFlags - return config - - -- Package has been configured, but the configuration may be out of - -- date or required flags may not be set. - -- - -- If we're in a sandbox: reinstall the modified add-source deps and - -- force reconfigure if we did. - onBuildConfig :: (UseSandbox, SavedConfig) -> FilePath - -> LBI.LocalBuildInfo -> IO SavedConfig - onBuildConfig (useSandbox, config) distPref lbi = do - let configFlags = LBI.configFlags lbi - distVerbFlags = mempty - { configVerbosity = toFlag verbosity - , configDistPref = toFlag distPref - } - flags = mconcat [configFlags, addConfigFlags, distVerbFlags] - - -- Was the sandbox created after the package was already configured? We - -- may need to skip reinstallation of add-source deps and force - -- reconfigure. - let buildConfig = localBuildInfoFile distPref - sandboxConfig <- getSandboxConfigFilePath globalFlags - isSandboxConfigNewer <- - sandboxConfig `existsAndIsMoreRecentThan` buildConfig - - let skipAddSourceDepsCheck' - | isSandboxConfigNewer = SkipAddSourceDepsCheck - | otherwise = skipAddSourceDepsCheck - - when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $ - info verbosity "Skipping add-source deps check..." - - let (_, config') = updateInstallDirs - (configUserInstall flags) - (useSandbox, config) - - depsReinstalled <- - case skipAddSourceDepsCheck' of - DontSkipAddSourceDepsCheck -> - maybeReinstallAddSourceDeps - verbosity numJobsFlag flags globalFlags - (useSandbox, config') - SkipAddSourceDepsCheck -> do - return NoDepsReinstalled - - -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need - -- to force reconfigure. Note that it's possible to use @cabal.config@ - -- even without sandboxes. - isUserPackageEnvironmentFileNewer <- - userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig - - -- Determine whether we need to reconfigure and which message to show to - -- the user if that is the case. - mMsg <- determineMessageToShow distPref lbi configFlags - depsReinstalled isSandboxConfigNewer - isUserPackageEnvironmentFileNewer - case mMsg of - - -- No message for the user indicates that reconfiguration - -- is not required. - Nothing -> return config' - - -- Show the message and reconfigure. - Just msg -> do - notice verbosity msg - configureAction (flags, defaultConfigExFlags) - extraArgs globalFlags - return config' - - -- Determine what message, if any, to display to the user if reconfiguration - -- is required. - determineMessageToShow :: FilePath -> LBI.LocalBuildInfo -> ConfigFlags - -> WereDepsReinstalled -> Bool -> Bool - -> IO (Maybe String) - determineMessageToShow _ _ _ _ True _ = - -- The sandbox was created after the package was already configured. - return $! Just $! sandboxConfigNewerMessage - - determineMessageToShow _ _ _ _ False True = - -- The user package environment file was modified. - return $! Just $! userPackageEnvironmentFileModifiedMessage - - determineMessageToShow distPref lbi configFlags depsReinstalled - False False = do - let savedDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags) - case depsReinstalled of - ReinstalledSomeDeps -> - -- Some add-source deps were reinstalled. - return $! Just $! reinstalledDepsMessage - NoDepsReinstalled -> - case checkFlags configFlags of - -- Flag required by the caller is not set. - Just msg -> return $! Just $! msg ++ configureManually - - Nothing - -- Required "dist" prefix is not set. - | savedDistPref /= distPref -> - return $! Just distPrefMessage - - -- All required flags are set, but the configuration - -- may be outdated. - | otherwise -> case LBI.pkgDescrFile lbi of - Nothing -> return Nothing - Just pdFile -> do - outdated <- checkPersistBuildConfigOutdated - distPref pdFile - return $! if outdated - then Just $! outdatedMessage pdFile - else Nothing - - reconfiguringMostRecent = " Re-configuring with most recently used options." - configureManually = " If this fails, please run configure manually." - sandboxConfigNewerMessage = - "The sandbox was created after the package was already configured." - ++ reconfiguringMostRecent - ++ configureManually - userPackageEnvironmentFileModifiedMessage = - "The user package environment file ('" - ++ userPackageEnvironmentFile ++ "') was modified." - ++ reconfiguringMostRecent - ++ configureManually - distPrefMessage = - "Package previously configured with different \"dist\" prefix." - ++ reconfiguringMostRecent - ++ configureManually - outdatedMessage pdFile = - pdFile ++ " has been changed." - ++ reconfiguringMostRecent - ++ configureManually - reinstalledDepsMessage = - "Some add-source dependencies have been reinstalled." - ++ reconfiguringMostRecent - ++ configureManually - -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -installAction (configFlags, _, installFlags, _) _ globalFlags - | fromFlagOrDefault False (installOnly installFlags) = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (configDistPref configFlags) - let setupOpts = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupOpts Nothing installCommand (const mempty) [] - -installAction (configFlags, configExFlags, installFlags, haddockFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- fmap - (updateInstallDirs (configUserInstall configFlags)) - (loadConfigOrSandboxConfig verbosity globalFlags) - targets <- readUserTargets verbosity extraArgs - - -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to - -- 'configure' when run inside a sandbox. Right now, running - -- - -- $ cabal sandbox init && cabal configure -w /path/to/ghc - -- && cabal build && cabal install - -- - -- performs the compilation twice unless you also pass -w to 'install'. - -- However, this is the same behaviour that 'cabal install' has in the normal - -- mode of operation, so we stick to it for consistency. - - let sandboxDistPref = case useSandbox of - NoSandbox -> NoFlag - UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir - distPref <- findSavedDistPref config - (configDistPref configFlags `mappend` sandboxDistPref) - - let configFlags' = maybeForceTests installFlags' $ - savedConfigureFlags config `mappend` - configFlags { configDistPref = toFlag distPref } - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, conf) <- configCompilerAux' configFlags' - -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the - -- future. - conf' <- configureAllKnownPrograms verbosity conf - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - configFlags'' <- case useSandbox of - NoSandbox -> configAbsolutePaths $ configFlags' - (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform - configFlags' - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp conf' - - indexFile <- tryGetIndexFilePath config - maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile - (compilerId comp) platform - - -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means - -- that 'cabal install some-package' inside a sandbox will sometimes reinstall - -- modified add-source deps, even if they are not among the dependencies of - -- 'some-package'. This can also prevent packages that depend on older - -- versions of add-source'd packages from building (see #1362). - maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags' - comp platform conf useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - install verbosity - (configPackageDB' configFlags'') - repoContext - comp platform conf' - useSandbox mSandboxPkgInfo - globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' - targets - - where - -- '--run-tests' implies '--enable-tests'. - maybeForceTests installFlags' configFlags' = - if fromFlagOrDefault False (installRunTests installFlags') - then configFlags' { configTests = toFlag True } - else configFlags' - -testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags - -> IO () -testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) - addConfigFlags = mempty { configTests = toFlag True } - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags } - checkFlags flags - | fromFlagOrDefault False (configTests flags) = Nothing - | otherwise = Just "Re-configuring with test suites enabled." - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - (useSandbox, config, distPref) <- - reconfigure verbosity (testDistPref testFlags) - addConfigFlags [] globalFlags noAddSource - (buildNumJobs buildFlags') checkFlags - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - testFlags' = testFlags { testDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "test suites" - (\c -> case c of { LBI.CTest{} -> True; _ -> False }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ name | LBI.CTestName name <- names' ] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.testCommand (const testFlags') extraArgs' - -data ComponentNames = ComponentNamesUnknown - | ComponentNames [LBI.ComponentName] - --- | Return the names of all buildable components matching a given predicate. -componentNamesFromLBI :: Verbosity -> FilePath -> String - -> (LBI.Component -> Bool) - -> IO ComponentNames -componentNamesFromLBI verbosity distPref targetsDescr compPred = do - eLBI <- tryGetPersistBuildConfig distPref - case eLBI of - Left err -> case err of - -- Note: the build config could have been generated by a custom setup - -- script built against a different Cabal version, so it's crucial that - -- we ignore the bad version error here. - ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die (show err) - Right lbi -> do - let pkgDescr = LBI.localPkgDescr lbi - names = map LBI.componentName - . filter (buildable . LBI.componentBuildInfo) - . filter compPred $ - LBI.pkgComponents pkgDescr - if null names - then do notice verbosity $ "Package has no buildable " - ++ targetsDescr ++ "." - exitSuccess -- See #3215. - - else return $! (ComponentNames names) - -benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) - -> [String] -> GlobalFlags - -> IO () -benchmarkAction (benchmarkFlags, buildFlags, buildExFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal - (benchmarkVerbosity benchmarkFlags) - addConfigFlags = mempty { configBenchmarks = toFlag True } - buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags } - checkFlags flags - | fromFlagOrDefault False (configBenchmarks flags) = Nothing - | otherwise = Just "Re-configuring with benchmarks enabled." - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - (useSandbox, config, distPref) <- - reconfigure verbosity (benchmarkDistPref benchmarkFlags) - addConfigFlags [] globalFlags noAddSource - (buildNumJobs buildFlags') checkFlags - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "benchmarks" - (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [name | LBI.CBenchName name <- names'] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' - -haddockAction :: HaddockFlags -> [String] -> Action -haddockAction haddockFlags extraArgs globalFlags = do - let verbosity = fromFlag (haddockVerbosity haddockFlags) - (_useSandbox, config, distPref) <- - reconfigure verbosity (haddockDistPref haddockFlags) - mempty [] globalFlags DontSkipAddSourceDepsCheck - NoFlag (const Nothing) - let haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') extraArgs - when (haddockForHackage haddockFlags == Flag True) $ do - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - let dest = distPref name <.> "tar.gz" - name = display (packageId pkg) ++ "-docs" - docDir = distPref "doc" "html" - createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - -cleanAction :: CleanFlags -> [String] -> Action -cleanAction cleanFlags extraArgs globalFlags = do - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (cleanDistPref cleanFlags) - let setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref - , useWin32CleanHack = True - } - cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } - setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') extraArgs - where - verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) - -listAction :: ListFlags -> [String] -> Action -listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` listPackageDBs listFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, conf) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.list verbosity - (configPackageDB' configFlags) - repoContext - comp - conf - listFlags - extraArgs - -infoAction :: InfoFlags -> [String] -> Action -infoAction infoFlags extraArgs globalFlags = do - let verbosity = fromFlag (infoVerbosity infoFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` infoPackageDBs infoFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, conf) <- configCompilerAuxEx configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.info verbosity - (configPackageDB' configFlags) - repoContext - comp - conf - globalFlags' - infoFlags - targets - -updateAction :: Flag Verbosity -> [String] -> Action -updateAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag verbosityFlag - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - update verbosity repoContext - -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -upgradeAction _ _ _ = die $ - "Use the 'cabal install' command instead of 'cabal upgrade'.\n" - ++ "You can install the latest version of a package using 'cabal install'. " - ++ "The 'cabal upgrade' command has been removed because people found it " - ++ "confusing and it often led to broken packages.\n" - ++ "If you want the old upgrade behaviour then use the install command " - ++ "with the --upgrade-dependencies flag (but check first with --dry-run " - ++ "to see what would happen). This will try to pick the latest versions " - ++ "of all dependencies, rather than the usual behaviour of trying to pick " - ++ "installed versions of all dependencies. If you do use " - ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " - ++ "packages (e.g. by using appropriate --constraint= flags)." - -fetchAction :: FetchFlags -> [String] -> Action -fetchAction fetchFlags extraArgs globalFlags = do - let verbosity = fromFlag (fetchVerbosity fetchFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, conf) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - fetch verbosity - (configPackageDB' configFlags) - repoContext - comp platform conf globalFlags' fetchFlags - targets - -freezeAction :: FreezeFlags -> [String] -> Action -freezeAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, conf) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo verbosity configFlags globalFlags' - comp platform conf useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - freeze verbosity - (configPackageDB' configFlags) - repoContext - comp platform conf - mSandboxPkgInfo - globalFlags' freezeFlags - -genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () -genBoundsAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, conf) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo verbosity configFlags globalFlags' - comp platform conf useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - genBounds verbosity - (configPackageDB' configFlags) - repoContext - comp platform conf - mSandboxPkgInfo - globalFlags' freezeFlags - -uploadAction :: UploadFlags -> [String] -> Action -uploadAction uploadFlags extraArgs globalFlags = do - config <- loadConfig verbosity (globalConfigFile globalFlags) - let uploadFlags' = savedUploadFlags config `mappend` uploadFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs - when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ - die "the 'upload' command expects at least one .tar.gz archive." - when (fromFlag (uploadCheck uploadFlags') - && fromFlag (uploadDoc uploadFlags')) $ - die "--check and --doc cannot be used together." - checkTarFiles extraArgs - maybe_password <- - case uploadPasswordCmd uploadFlags' - of Flag (xs:xss) -> Just . Password <$> - getProgramInvocationOutput verbosity - (simpleProgramInvocation xs xss) - _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' - withRepoContext verbosity globalFlags' $ \repoContext -> do - if fromFlag (uploadCheck uploadFlags') - then do - Upload.check verbosity repoContext tarfiles - else if fromFlag (uploadDoc uploadFlags') - then do - when (length tarfiles > 1) $ - die $ "the 'upload' command can only upload documentation " - ++ "for one package at a time." - tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles - Upload.uploadDoc verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - tarfile - else do - Upload.upload verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - tarfiles - where - verbosity = fromFlag (uploadVerbosity uploadFlags) - checkTarFiles tarfiles - | not (null otherFiles) - = die $ "the 'upload' command expects only .tar.gz archives: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False - generateDocTarball config = do - notice verbosity $ - "No documentation tarball specified. " - ++ "Building a documentation tarball with default settings...\n" - ++ "If you need to customise Haddock options, " - ++ "run 'haddock --for-hackage' first " - ++ "to generate a documentation tarball." - haddockAction (defaultHaddockFlags { haddockForHackage = Flag True }) - [] globalFlags - distPref <- findSavedDistPref config NoFlag - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" - -checkAction :: Flag Verbosity -> [String] -> Action -checkAction verbosityFlag extraArgs _globalFlags = do - unless (null extraArgs) $ - die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs - allOk <- Check.check (fromFlag verbosityFlag) - unless allOk exitFailure - -formatAction :: Flag Verbosity -> [String] -> Action -formatAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - path <- case extraArgs of - [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc cwd - (p:_) -> return p - pkgDesc <- readPackageDescription verbosity path - -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc - -uninstallAction :: Flag Verbosity -> [String] -> Action -uninstallAction _verbosityFlag extraArgs _globalFlags = do - let package = case extraArgs of - p:_ -> p - _ -> "PACKAGE_NAME" - die $ "This version of 'cabal-install' does not support the 'uninstall' " - ++ "operation. " - ++ "It will likely be implemented at some point in the future; " - ++ "in the meantime you're advised to use either 'ghc-pkg unregister " - ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." - - -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action -sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (sDistVerbosity sdistFlags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (sDistDistPref sdistFlags) - let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } - sdist sdistFlags' sdistExFlags - -reportAction :: ReportFlags -> [String] -> Action -reportAction reportFlags extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - - let verbosity = fromFlag (reportVerbosity reportFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - reportFlags' = savedReportFlags config `mappend` reportFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - Upload.report verbosity repoContext - (flagToMaybe $ reportUsername reportFlags') - (flagToMaybe $ reportPassword reportFlags') - -runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -runAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - (useSandbox, config, distPref) <- - reconfigure verbosity (buildDistPref buildFlags) mempty [] - globalFlags noAddSource (buildNumJobs buildFlags) - (const Nothing) - - lbi <- getPersistBuildConfig distPref - (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags ["exe:" ++ exeName exe] - - maybeWithSandboxDirOnSearchPath useSandbox $ - run verbosity lbi exe exeArgs - -getAction :: GetFlags -> [String] -> Action -getAction getFlags extraArgs globalFlags = do - let verbosity = fromFlag (getVerbosity getFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> - get verbosity - repoContext - globalFlags' - getFlags - targets - -unpackAction :: GetFlags -> [String] -> Action -unpackAction getFlags extraArgs globalFlags = do - getAction getFlags extraArgs globalFlags - -initAction :: InitFlags -> [String] -> Action -initAction initFlags extraArgs globalFlags = do - when (extraArgs /= []) $ - die $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (initVerbosity initFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags = savedConfigureFlags config - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, conf) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - initCabal verbosity - (configPackageDB' configFlags) - repoContext - comp - conf - initFlags - -sandboxAction :: SandboxFlags -> [String] -> Action -sandboxAction sandboxFlags extraArgs globalFlags = do - let verbosity = fromFlag (sandboxVerbosity sandboxFlags) - case extraArgs of - -- Basic sandbox commands. - ["init"] -> sandboxInit verbosity sandboxFlags globalFlags - ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags - ("add-source":extra) -> do - when (noExtraArgs extra) $ - die "The 'sandbox add-source' command expects at least one argument" - sandboxAddSource verbosity extra sandboxFlags globalFlags - ("delete-source":extra) -> do - when (noExtraArgs extra) $ - die ("The 'sandbox delete-source' command expects " ++ - "at least one argument") - sandboxDeleteSource verbosity extra sandboxFlags globalFlags - ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags - - -- More advanced commands. - ("hc-pkg":extra) -> do - when (noExtraArgs extra) $ - die $ "The 'sandbox hc-pkg' command expects at least one argument" - sandboxHcPkg verbosity sandboxFlags globalFlags extra - ["buildopts"] -> die "Not implemented!" - - -- Hidden commands. - ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags - - -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help sandbox')" - _ -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs - - where - noExtraArgs = (<1) . length - -execAction :: ExecFlags -> [String] -> Action -execAction execFlags extraArgs globalFlags = do - let verbosity = fromFlag (execVerbosity execFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - (comp, platform, conf) <- getPersistOrConfigCompiler configFlags - exec verbosity useSandbox comp platform conf extraArgs - -userConfigAction :: UserConfigFlags -> [String] -> Action -userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) - force = fromFlag (userConfigForce ucflags) - case extraArgs of - ("init":_) -> do - path <- configFile - fileExists <- doesFileExist path - if (not fileExists || (fileExists && force)) - then void $ createDefaultConfigFile verbosity path - else die $ path ++ " already exists." - ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags - ("update":_) -> userConfigUpdate verbosity globalFlags - -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help user-config')" - _ -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs - where configFile = getConfigFilePath (globalConfigFile globalFlags) - --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --- -win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action -win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do - let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -win32SelfUpgradeAction _ _ _ = return () - --- | Used as an entry point when cabal-install needs to invoke itself --- as a setup script. This can happen e.g. when doing parallel builds. --- -actAsSetupAction :: ActAsSetupFlags -> [String] -> Action -actAsSetupAction actAsSetupFlags args _globalFlags = - let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) - in case bt of - Simple -> Simple.defaultMainArgs args - Configure -> Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks args - Make -> Make.defaultMainArgs args - Custom -> error "actAsSetupAction Custom" - (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" - -manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action -manpageAction commands _ extraArgs _ = do - unless (null extraArgs) $ - die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs + , reconfigureCommand + , configCompilerAux', configPackageDB' + , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) + , buildCommand, replCommand, testCommand, benchmarkCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand, uninstallCommand + , FetchFlags(..), fetchCommand + , FreezeFlags(..), freezeCommand + , genBoundsCommand + , OutdatedFlags(..), outdatedCommand + , GetFlags(..), getCommand, unpackCommand + , checkCommand + , formatCommand + , updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , runCommand + , InitFlags(initVerbosity), initCommand + , SDistFlags(..), SDistExFlags(..), sdistCommand + , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , ActAsSetupFlags(..), actAsSetupCommand + , SandboxFlags(..), sandboxCommand + , ExecFlags(..), execCommand + , UserConfigFlags(..), userConfigCommand + , reportCommand + , manpageCommand + ) +import Distribution.Simple.Setup + ( HaddockTarget(..) + , DoctestFlags(..), doctestCommand + , HaddockFlags(..), haddockCommand, defaultHaddockFlags + , HscolourFlags(..), hscolourCommand + , ReplFlags(..) + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , TestFlags(..), BenchmarkFlags(..) + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag + , configAbsolutePaths + ) + +import Prelude () +import Distribution.Client.Compat.Prelude hiding (get) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff + , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) +import Distribution.Client.Targets + ( readUserTargets ) +import qualified Distribution.Client.List as List + ( list, info ) + +import qualified Distribution.Client.CmdConfigure as CmdConfigure +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench + +import Distribution.Client.Install (install) +import Distribution.Client.Configure (configure, writeConfigFlags) +import Distribution.Client.Update (update) +import Distribution.Client.Exec (exec) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Freeze (freeze) +import Distribution.Client.GenBounds (genBounds) +import Distribution.Client.Outdated (outdated) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import qualified Distribution.Client.Upload as Upload +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Get (get) +import Distribution.Client.Reconfigure (Check(..), reconfigure) +import Distribution.Client.Nix (nixInstantiate + ,nixShell + ,nixShellIfSandboxed) +import Distribution.Client.Sandbox (sandboxInit + ,sandboxAddSource + ,sandboxDelete + ,sandboxDeleteSource + ,sandboxListSources + ,sandboxHcPkg + ,dumpPackageEnvironment + + ,loadConfigOrSandboxConfig + ,findSavedDistPref + ,initPackageDBIfNeeded + ,maybeWithSandboxDirOnSearchPath + ,maybeWithSandboxPackageInfo + ,tryGetIndexFilePath + ,sandboxBuildDir + ,updateSandboxConfigFileFlag + ,updateInstallDirs + + ,getPersistOrConfigCompiler) +import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) +import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) +import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) +import Distribution.Client.Tar (createTarGzFile) +import Distribution.Client.Types (Password (..)) +import Distribution.Client.Init (initCabal) +import Distribution.Client.Manpage (manpage) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import Distribution.Client.Utils (determineNumJobs +#if defined(mingw32_HOST_OS) + ,relaxEncodingErrors +#endif + ) + +import Distribution.Package (packageId) +import Distribution.PackageDescription + ( BuildType(..), Executable(..), buildable ) +#ifdef CABAL_PARSEC +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) +#else +import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) +#endif + +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import qualified Distribution.Simple as Simple +import qualified Distribution.Make as Make +import qualified Distribution.Types.UnqualComponentName as Make +import Distribution.Simple.Build + ( startInterpreter ) +import Distribution.Simple.Command + ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) + , CommandType(..), commandsRun, commandAddAction, hiddenCommand + , commandFromSpec, commandShowOptions ) +import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) +import Distribution.Simple.Configure + ( configCompilerAuxEx, ConfigStateFileError(..) + , getPersistBuildConfig, interpretPackageDbFlags + , tryGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program (defaultProgramDb + ,configureAllKnownPrograms + ,simpleProgramInvocation + ,getProgramInvocationOutput) +import Distribution.Simple.Program.Db (reconfigurePrograms) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Utils + ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler + , findPackageDesc, tryFindPackageDesc ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Version + ( Version, mkVersion, orLaterVersion ) +import qualified Paths_cabal_install (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath ( dropExtension, splitExtension + , takeExtension, (), (<.>)) +import System.IO ( BufferMode(LineBuffering), hSetBuffering +#ifdef mingw32_HOST_OS + , stderr +#endif + , stdout ) +import System.Directory (doesFileExist, getCurrentDirectory) +import Data.Monoid (Any(..)) +import Control.Exception (SomeException(..), try) +import Control.Monad (mapM_) + +#ifdef MONOLITHIC +import qualified UnitTests +import qualified MemoryUsageTests +import qualified SolverQuickCheck +import qualified IntegrationTests2 +import qualified System.Environment as Monolithic +#endif + +-- | Entry point +-- +main :: IO () +#ifdef MONOLITHIC +main = do + mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" + case mb_exec of + Just "UnitTests" -> UnitTests.main + Just "MemoryUsageTests" -> MemoryUsageTests.main + Just "SolverQuickCheck" -> SolverQuickCheck.main + Just "IntegrationTests2" -> IntegrationTests2.main + Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" + Nothing -> main' +#else +main = main' +#endif + +main' :: IO () +main' = do + -- Enable line buffering so that we can get fast feedback even when piped. + -- This is especially important for CI and build systems. + hSetBuffering stdout LineBuffering + -- The default locale encoding for Windows CLI is not UTF-8 and printing + -- Unicode characters to it will fail unless we relax the handling of encoding + -- errors when writing to stderr and stdout. +#ifdef mingw32_HOST_OS + relaxEncodingErrors stdout + relaxEncodingErrors stderr +#endif + getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker args = topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ | fromFlagOrDefault False (globalVersion globalFlags) + -> printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) + -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> do + globalFlags' <- updateSandboxConfigFileFlag globalFlags + action globalFlags' + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + exists <- doesFileExist configFile + when (not exists) $ + putStrLn $ "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." + printOptionsList = putStr . unlines + printErrors errs = dieNoVerbosity $ intercalate "\n" errs + printNumericVersion = putStrLn $ display Paths_cabal_install.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ "\ncompiled using version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = map commandFromSpec commandSpecs + commandSpecs = + [ regularCmd installCommand installAction + , regularCmd updateCommand updateAction + , regularCmd listCommand listAction + , regularCmd infoCommand infoAction + , regularCmd fetchCommand fetchAction + , regularCmd freezeCommand freezeAction + , regularCmd getCommand getAction + , hiddenCmd unpackCommand unpackAction + , regularCmd checkCommand checkAction + , regularCmd sdistCommand sdistAction + , regularCmd uploadCommand uploadAction + , regularCmd reportCommand reportAction + , regularCmd runCommand runAction + , regularCmd initCommand initAction + , regularCmd configureExCommand configureAction + , regularCmd reconfigureCommand reconfigureAction + , regularCmd buildCommand buildAction + , regularCmd replCommand replAction + , regularCmd sandboxCommand sandboxAction + , regularCmd doctestCommand doctestAction + , regularCmd haddockCommand haddockAction + , regularCmd execCommand execAction + , regularCmd userConfigCommand userConfigAction + , regularCmd cleanCommand cleanAction + , regularCmd genBoundsCommand genBoundsAction + , regularCmd outdatedCommand outdatedAction + , wrapperCmd copyCommand copyVerbosity copyDistPref + , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref + , wrapperCmd registerCommand regVerbosity regDistPref + , regularCmd testCommand testAction + , regularCmd benchmarkCommand benchmarkAction + , hiddenCmd uninstallCommand uninstallAction + , hiddenCmd formatCommand formatAction + , hiddenCmd upgradeCommand upgradeAction + , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction + , hiddenCmd actAsSetupCommand actAsSetupAction + , hiddenCmd manpageCommand (manpageAction commandSpecs) + + , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , regularCmd CmdBuild.buildCommand CmdBuild.buildAction + , regularCmd CmdRepl.replCommand CmdRepl.replAction + , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , regularCmd CmdRun.runCommand CmdRun.runAction + , regularCmd CmdTest.testCommand CmdTest.testAction + , regularCmd CmdBench.benchCommand CmdBench.benchAction + ] + +type Action = GlobalFlags -> IO () + +regularCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) action) NormalCommand + +hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +hiddenCmd ui action = + CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) + HiddenCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) + -> (flags -> Flag String) -> CommandSpec Action +wrapperCmd ui verbosity distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command Action +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + nixInstantiate verbosity distPref True globalFlags config + nixShell verbosity distPref globalFlags config $ do + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAuxEx configFlags' + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + let configFlags'' = case useSandbox of + NoSandbox -> configFlags' + (UseSandbox sandboxDir) -> setPackageDB sandboxDir + comp platform configFlags' + + writeConfigFlags verbosity distPref (configFlags'', configExFlags') + + -- What package database(s) to use + let packageDBs :: PackageDBStack + packageDBs + = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags'')) + (configPackageDBs configFlags'') + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verbosity configFlags'' comp progdb + -- NOTE: We do not write the new sandbox package DB location to + -- 'cabal.sandbox.config' here because 'configure -w' must not affect + -- subsequent 'install' (for UI compatibility with non-sandboxed mode). + + indexFile <- tryGetIndexFilePath verbosity config + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + configure verbosity packageDBs repoContext + comp platform progdb configFlags'' configExFlags' extraArgs + +reconfigureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +reconfigureAction flags@(configFlags, _) _ globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + let checkFlags = Check $ \_ saved -> do + let flags' = saved <> flags + unless (saved == flags') $ info verbosity message + pure (Any True, flags') + where + -- This message is correct, but not very specific: it will list all + -- of the new flags, even if some have not actually changed. The + -- *minimal* set of changes is more difficult to determine. + message = + "flags changed: " + ++ unwords (commandShowOptions configureExCommand flags) + nixInstantiate verbosity distPref True globalFlags config + _ <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + checkFlags [] globalFlags config + pure () + +buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags extraArgs + + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity config distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + (Cabal.buildCommand progDb) mkBuildFlags extraArgs + where + progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + + mkBuildFlags version = filterBuildFlags version config buildFlags' + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +-- | Make sure that we don't pass new flags to setup scripts compiled against +-- old versions of Cabal. +filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags +filterBuildFlags version config buildFlags + | version >= mkVersion [1,19,1] = buildFlags_latest + -- Cabal < 1.19.1 doesn't support 'build -j'. + | otherwise = buildFlags_pre_1_19_1 + where + buildFlags_pre_1_19_1 = buildFlags { + buildNumJobs = NoFlag + } + buildFlags_latest = buildFlags { + -- Take the 'jobs' setting '~/.cabal/config' into account. + buildNumJobs = Flag . Just . determineNumJobs $ + (numJobsConfigFlag `mappend` numJobsCmdLineFlag) + } + numJobsConfigFlag = installNumJobs . savedInstallFlags $ config + numJobsCmdLineFlag = buildNumJobs buildFlags + + +replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action +replAction (replFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (replDistPref replFlags) + cwd <- getCurrentDirectory + pkgDesc <- findPackageDesc cwd + let + -- There is a .cabal file in the current directory: start a REPL and load + -- the project's modules. + onPkgDesc = do + let noAddSource = case replReload replFlags of + Flag True -> SkipAddSourceDepsCheck + _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- Calls 'configureAction' to do the real work, so nothing special has to + -- be done to support sandboxes. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource NoFlag + mempty [] globalFlags config + let progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] + , useDistPref = distPref + } + replFlags' = replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } + + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + (Cabal.replCommand progDb) (const replFlags') extraArgs + + -- No .cabal file in the current directory: just start the REPL (possibly + -- using the sandbox package DB). + onNoPkgDesc = do + let configFlags = savedConfigureFlags config + (comp, platform, programDb) <- configCompilerAux' configFlags + programDb' <- reconfigurePrograms verbosity + (replProgramPaths replFlags) + (replProgramArgs replFlags) + programDb + nixShell verbosity distPref globalFlags config $ do + startInterpreter verbosity programDb' comp platform + (configPackageDB' configFlags) + + either (const onNoPkgDesc) (const onPkgDesc) pkgDesc + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +installAction (configFlags, _, installFlags, _) _ globalFlags + | fromFlagOrDefault False (installOnly installFlags) = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags + dist <- findSavedDistPref config (configDistPref configFlags) + let setupOpts = defaultSetupScriptOptions { useDistPref = dist } + nixShellIfSandboxed verb dist globalFlags config useSandbox $ + setupWrapper + verb setupOpts Nothing + installCommand (const mempty) [] + +installAction + (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verb globalFlags + + let sandboxDist = + case useSandbox of + NoSandbox -> NoFlag + UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir + dist <- findSavedDistPref config + (configDistPref configFlags `mappend` sandboxDist) + + nixShellIfSandboxed verb dist globalFlags config useSandbox $ do + targets <- readUserTargets verb extraArgs + + -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to + -- 'configure' when run inside a sandbox. Right now, running + -- + -- $ cabal sandbox init && cabal configure -w /path/to/ghc + -- && cabal build && cabal install + -- + -- performs the compilation twice unless you also pass -w to 'install'. + -- However, this is the same behaviour that 'cabal install' has in the normal + -- mode of operation, so we stick to it for consistency. + + let configFlags' = maybeForceTests installFlags' $ + savedConfigureFlags config `mappend` + configFlags { configDistPref = toFlag dist } + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config `mappend` + haddockFlags { haddockDistPref = toFlag dist } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags' + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + progdb' <- configureAllKnownPrograms verb progdb + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + configFlags'' <- case useSandbox of + NoSandbox -> configAbsolutePaths $ configFlags' + (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform + configFlags' + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verb configFlags'' comp progdb' + + indexFile <- tryGetIndexFilePath verb config + maybeAddCompilerTimestampRecord verb sandboxDir indexFile + (compilerId comp) platform + + -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means + -- that 'cabal install some-package' inside a sandbox will sometimes reinstall + -- modified add-source deps, even if they are not among the dependencies of + -- 'some-package'. This can also prevent packages that depend on older + -- versions of add-source'd packages from building (see #1362). + maybeWithSandboxPackageInfo verb configFlags'' globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verb globalFlags' $ \repoContext -> + install verb + (configPackageDB' configFlags'') + repoContext + comp platform progdb' + useSandbox mSandboxPkgInfo + globalFlags' configFlags'' configExFlags' + installFlags' haddockFlags' + targets + + where + -- '--run-tests' implies '--enable-tests'. + maybeForceTests installFlags' configFlags' = + if fromFlagOrDefault False (installRunTests installFlags') + then configFlags' { configTests = toFlag True } + else configFlags' + +testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags + -> IO () +testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (testDistPref testFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + buildFlags' = buildFlags + { buildVerbosity = testVerbosity testFlags } + checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configTests configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable tests" + let flags' = ( configFlags { configTests = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + testFlags' = testFlags { testDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "test suites" + (\c -> case c of { LBI.CTest{} -> True; _ -> False }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' ] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.testCommand (const testFlags') extraArgs' + +data ComponentNames = ComponentNamesUnknown + | ComponentNames [LBI.ComponentName] + +-- | Return the names of all buildable components matching a given predicate. +componentNamesFromLBI :: Verbosity -> FilePath -> String + -> (LBI.Component -> Bool) + -> IO ComponentNames +componentNamesFromLBI verbosity distPref targetsDescr compPred = do + eLBI <- tryGetPersistBuildConfig distPref + case eLBI of + Left err -> case err of + -- Note: the build config could have been generated by a custom setup + -- script built against a different Cabal version, so it's crucial that + -- we ignore the bad version error here. + ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown + _ -> die' verbosity (show err) + Right lbi -> do + let pkgDescr = LBI.localPkgDescr lbi + names = map LBI.componentName + . filter (buildable . LBI.componentBuildInfo) + . filter compPred $ + LBI.pkgComponents pkgDescr + if null names + then do notice verbosity $ "Package has no buildable " + ++ targetsDescr ++ "." + exitSuccess -- See #3215. + + else return $! (ComponentNames names) + +benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) + -> [String] -> GlobalFlags + -> IO () +benchmarkAction + (benchmarkFlags, buildFlags, buildExFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal + (benchmarkVerbosity benchmarkFlags) + + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + let buildFlags' = buildFlags + { buildVerbosity = benchmarkVerbosity benchmarkFlags } + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configBenchmarks configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable benchmarks" + let flags' = ( configFlags { configBenchmarks = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "benchmarks" + (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names'] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' + +haddockAction :: HaddockFlags -> [String] -> Action +haddockAction haddockFlags extraArgs globalFlags = do + let verbosity = fromFlag (haddockVerbosity haddockFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (haddockDistPref haddockFlags) + config' <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config' `mappend` + haddockFlags { haddockDistPref = toFlag distPref } + setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + haddockCommand (const haddockFlags') extraArgs + when (haddockForHackage haddockFlags == Flag ForHackage) $ do + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + let dest = distPref name <.> "tar.gz" + name = display (packageId pkg) ++ "-docs" + docDir = distPref "doc" "html" + createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + +doctestAction :: DoctestFlags -> [String] -> Action +doctestAction doctestFlags extraArgs _globalFlags = do + let verbosity = fromFlag (doctestVerbosity doctestFlags) + + setupWrapper verbosity defaultSetupScriptOptions Nothing + doctestCommand (const doctestFlags) extraArgs + +cleanAction :: CleanFlags -> [String] -> Action +cleanAction cleanFlags extraArgs globalFlags = do + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (cleanDistPref cleanFlags) + let setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref + , useWin32CleanHack = True + } + cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } + setupWrapper verbosity setupScriptOptions Nothing + cleanCommand (const cleanFlags') extraArgs + where + verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) + +listAction :: ListFlags -> [String] -> Action +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` listPackageDBs listFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.list verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> Action +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` infoPackageDBs infoFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAuxEx configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.info verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + globalFlags' + infoFlags + targets + +updateAction :: Flag Verbosity -> [String] -> Action +updateAction verbosityFlag extraArgs globalFlags = do + let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + update verbosity repoContext + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ + "Use the 'cabal install' command instead of 'cabal upgrade'.\n" + ++ "You can install the latest version of a package using 'cabal install'. " + ++ "The 'cabal upgrade' command has been removed because people found it " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." + where + verbosity = fromFlag (configVerbosity configFlags) + +fetchAction :: FetchFlags -> [String] -> Action +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + fetch verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb globalFlags' fetchFlags + targets + +freezeAction :: FreezeFlags -> [String] -> Action +freezeAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + freeze verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () +genBoundsAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + genBounds verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () +outdatedAction outdatedFlags _extraArgs globalFlags = do + let verbosity = fromFlag (outdatedVerbosity outdatedFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, _progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + outdated verbosity outdatedFlags repoContext + comp platform + +uploadAction :: UploadFlags -> [String] -> Action +uploadAction uploadFlags extraArgs globalFlags = do + config <- loadConfig verbosity (globalConfigFile globalFlags) + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ + die' verbosity "the 'upload' command expects at least one .tar.gz archive." + checkTarFiles extraArgs + maybe_password <- + case uploadPasswordCmd uploadFlags' + of Flag (xs:xss) -> Just . Password <$> + getProgramInvocationOutput verbosity + (simpleProgramInvocation xs xss) + _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + withRepoContext verbosity globalFlags' $ \repoContext -> do + if fromFlag (uploadDoc uploadFlags') + then do + when (length tarfiles > 1) $ + die' verbosity $ "the 'upload' command can only upload documentation " + ++ "for one package at a time." + tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles + Upload.uploadDoc verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfile + else do + Upload.upload verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfiles + where + verbosity = fromFlag (uploadVerbosity uploadFlags) + checkTarFiles tarfiles + | not (null otherFiles) + = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + generateDocTarball config = do + notice verbosity $ + "No documentation tarball specified. " + ++ "Building a documentation tarball with default settings...\n" + ++ "If you need to customise Haddock options, " + ++ "run 'haddock --for-hackage' first " + ++ "to generate a documentation tarball." + haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) + [] globalFlags + distPref <- findSavedDistPref config NoFlag + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" + +checkAction :: Flag Verbosity -> [String] -> Action +checkAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + +formatAction :: Flag Verbosity -> [String] -> Action +formatAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + path <- case extraArgs of + [] -> do cwd <- getCurrentDirectory + tryFindPackageDesc cwd + (p:_) -> return p + pkgDesc <- readGenericPackageDescription verbosity path + -- Uses 'writeFileAtomic' under the hood. + writeGenericPackageDescription path pkgDesc + +uninstallAction :: Flag Verbosity -> [String] -> Action +uninstallAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + package = case extraArgs of + p:_ -> p + _ -> "PACKAGE_NAME" + die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " + ++ "operation. " + ++ "It will likely be implemented at some point in the future; " + ++ "in the meantime you're advised to use either 'ghc-pkg unregister " + ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." + + +sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action +sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do + let verbosity = fromFlag (sDistVerbosity sdistFlags) + unless (null extraArgs) $ + die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (sDistDistPref sdistFlags) + let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } + sdist sdistFlags' sdistExFlags + +reportAction :: ReportFlags -> [String] -> Action +reportAction reportFlags extraArgs globalFlags = do + let verbosity = fromFlag (reportVerbosity reportFlags) + unless (null extraArgs) $ + die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + Upload.report verbosity repoContext + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +runAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + lbi <- getPersistBuildConfig distPref + (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] + + maybeWithSandboxDirOnSearchPath useSandbox $ + run verbosity lbi exe exeArgs + +getAction :: GetFlags -> [String] -> Action +getAction getFlags extraArgs globalFlags = do + let verbosity = fromFlag (getVerbosity getFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> + get verbosity + repoContext + globalFlags' + getFlags + targets + +unpackAction :: GetFlags -> [String] -> Action +unpackAction getFlags extraArgs globalFlags = do + getAction getFlags extraArgs globalFlags + +initAction :: InitFlags -> [String] -> Action +initAction initFlags extraArgs globalFlags = do + let verbosity = fromFlag (initVerbosity initFlags) + when (extraArgs /= []) $ + die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags = savedConfigureFlags config + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + initCabal verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + initFlags + +sandboxAction :: SandboxFlags -> [String] -> Action +sandboxAction sandboxFlags extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + case extraArgs of + -- Basic sandbox commands. + ["init"] -> sandboxInit verbosity sandboxFlags globalFlags + ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags + ("add-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity "The 'sandbox add-source' command expects at least one argument" + sandboxAddSource verbosity extra sandboxFlags globalFlags + ("delete-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity ("The 'sandbox delete-source' command expects " ++ + "at least one argument") + sandboxDeleteSource verbosity extra sandboxFlags globalFlags + ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags + + -- More advanced commands. + ("hc-pkg":extra) -> do + when (noExtraArgs extra) $ + die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" + sandboxHcPkg verbosity sandboxFlags globalFlags extra + ["buildopts"] -> die' verbosity "Not implemented!" + + -- Hidden commands. + ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags + + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" + _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs + + where + noExtraArgs = (<1) . length + +execAction :: ExecFlags -> [String] -> Action +execAction execFlags extraArgs globalFlags = do + let verbosity = fromFlag (execVerbosity execFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (execDistPref execFlags) + let configFlags = savedConfigureFlags config + configFlags' = configFlags { configDistPref = Flag distPref } + (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' + exec verbosity useSandbox comp platform progdb extraArgs + +userConfigAction :: UserConfigFlags -> [String] -> Action +userConfigAction ucflags extraArgs globalFlags = do + let verbosity = fromFlag (userConfigVerbosity ucflags) + force = fromFlag (userConfigForce ucflags) + case extraArgs of + ("init":_) -> do + path <- configFile + fileExists <- doesFileExist path + if (not fileExists || (fileExists && force)) + then void $ createDefaultConfigFile verbosity path + else die' verbosity $ path ++ " already exists." + ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags + ("update":_) -> userConfigUpdate verbosity globalFlags + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + where configFile = getConfigFilePath (globalConfigFile globalFlags) + +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action +win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do + let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse +win32SelfUpgradeAction _ _ _ = return () + +-- | Used as an entry point when cabal-install needs to invoke itself +-- as a setup script. This can happen e.g. when doing parallel builds. +-- +actAsSetupAction :: ActAsSetupFlags -> [String] -> Action +actAsSetupAction actAsSetupFlags args _globalFlags = + let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" + (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" + +manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action +manpageAction commands flagVerbosity extraArgs _ = do + let verbosity = fromFlag flagVerbosity + unless (null extraArgs) $ + die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs pname <- getProgName let cabalCmd = if takeExtension pname == ".exe" then dropExtension pname diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -11,7 +11,7 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) , absoluteInstallDirs ) -import Distribution.Simple.Utils ( copyFiles +import Distribution.Simple.Utils ( installOrdinaryFiles , notice ) import Distribution.Simple.Setup ( buildVerbosity , copyDest @@ -27,6 +27,16 @@ import System.Process ( runProcess ) import System.FilePath ( () ) +-- WARNING to editors of this file: +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- At this moment (Cabal 1.23), whatever you write here must be +-- compatible with ALL Cabal libraries which we support bootstrapping +-- with. This is because pre-setup-depends versions of cabal-install will +-- build Setup.hs against the version of Cabal which MATCHES the library +-- that cabal-install was built against. There is no way of overriding +-- this behavior without bumping the required 'cabal-version' in our +-- Cabal file. Travis will let you know if we fail to install from +-- tarball! main :: IO () main = defaultMainWithHooks $ simpleUserHooks @@ -50,4 +60,4 @@ installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO () installManpage pkg lbi verbosity copy = do let destDir = mandir (absoluteInstallDirs pkg lbi copy) "man1" - copyFiles verbosity destDir [(buildDir lbi "cabal", "cabal.1")] + installOrdinaryFiles verbosity destDir [(buildDir lbi "cabal", "cabal.1")] diff --git a/bash-completion/cabal b/bash-completion/cabal --- a/bash-completion/cabal +++ b/bash-completion/cabal @@ -10,9 +10,10 @@ # - executable|test-suite|benchmark for the three _cabal_list() { - cat *.cabal | - grep -Ei "^[[:space:]]*($1)[[:space:]]" | - sed -e "s/.* \([^ ]*\).*/\1/" + for f in ./*.cabal; do + grep -Ei "^[[:space:]]*($1)[[:space:]]" "$f" | + sed -e "s/.* \([^ ]*\).*/\1/" + done } # List possible targets depending on the command supplied as parameter. The @@ -20,17 +21,17 @@ # This is a temporary workaround. _cabal_targets() { - # If command ($*) contains build, repl, test or bench completes with - # targets of according type. - [ -f *.cabal ] || return 0 - local comp - for comp in $*; do - [ $comp == build ] && _cabal_list "executable|test-suite|benchmark" && break - [ $comp == repl ] && _cabal_list "executable|test-suite|benchmark" && break - [ $comp == run ] && _cabal_list "executable" && break - [ $comp == test ] && _cabal_list "test-suite" && break - [ $comp == bench ] && _cabal_list "benchmark" && break - done + # If command ($*) contains build, repl, test or bench completes with + # targets of according type. + local comp + for comp in "$@"; do + [ "$comp" == new-build ] && _cabal_list "executable|test-suite|benchmark" && break + [ "$comp" == build ] && _cabal_list "executable|test-suite|benchmark" && break + [ "$comp" == repl ] && _cabal_list "executable|test-suite|benchmark" && break + [ "$comp" == run ] && _cabal_list "executable" && break + [ "$comp" == test ] && _cabal_list "test-suite" && break + [ "$comp" == bench ] && _cabal_list "benchmark" && break + done } # List possible subcommands of a cabal subcommand. @@ -87,7 +88,7 @@ cmd[${COMP_CWORD}]="--list-options" # the resulting completions should be put into this array - COMPREPLY=( $( compgen -W "$( ${cmd[@]} ) $( _cabal_targets ${cmd[@]} ) $( _cabal_subcommands ${COMP_WORDS[@]} )" -- $cur ) ) + COMPREPLY=( $( compgen -W "$( eval "${cmd[@]}" 2>/dev/null ) $( _cabal_targets "${cmd[@]}" ) $( _cabal_subcommands "${COMP_WORDS[@]}" )" -- "$cur" ) ) } complete -F _cabal -o default cabal diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -16,7 +16,10 @@ #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS -die () { printf "\nError during cabal-install bootstrap:\n$1\n" >&2 && exit 2 ;} +die() { + printf "\nError during cabal-install bootstrap:\n%s\n" "$1" >&2 + exit 2 +} # programs, you can override these by setting environment vars GHC="${GHC:-ghc}" @@ -51,13 +54,12 @@ SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" -# Try to respect $TMPDIR. -[ -"$TMPDIR"- = -""- ] && - export TMPDIR=/tmp/cabal-$(echo $(od -XN4 -An /dev/random)) && mkdir $TMPDIR +TMPDIR=$(mktemp -d -p /tmp -t cabal-XXXXXXX || mktemp -d -t cabal-XXXXXXX) +export TMPDIR # Check for a C compiler, using user-set $CC, if any, first. for c in $CC gcc clang cc icc; do - $c --version 2>&1 >/dev/null && CC=$c && + $c --version 1>/dev/null 2>&1 && CC=$c && echo "Using $c for C compiler. If this is not what you want, set CC." >&2 && break done @@ -67,9 +69,15 @@ If a C compiler is installed make sure it is on your PATH, or set $CC.' # Find the correct linker/linker-wrapper. +# +# See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153. LINK="$(for link in collect2 ld; do - [ $($CC -print-prog-name=$link) = $link ] && continue || - $CC -print-prog-name=$link + if [ $($CC -print-prog-name=$link) = $link ] + then + continue + else + $CC -print-prog-name=$link && break + fi done)" # Fall back to "ld"... might work. @@ -158,9 +166,9 @@ esac done -# Do not try to use -j with GHC older than 7.8 +# Do not try to use -j with GHC 7.8 or older case $GHC_VER in - 7.4*|7.6*) + 7.4*|7.6*|7.8*) JOBS="" ;; *) @@ -200,9 +208,9 @@ # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.9"; PARSEC_VER_REGEXP="[3]\.[01]\." +PARSEC_VER="3.1.11"; PARSEC_VER_REGEXP="[3]\.[01]\." # >= 3.0 && < 3.2 -DEEPSEQ_VER="1.4.2.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." +DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 case "$GHC_VER" in @@ -213,35 +221,35 @@ ;; *) # GHC >= 7.8 - BINARY_VER="0.8.3.0" + BINARY_VER="0.8.5.1" BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9 ;; esac -TEXT_VER="1.2.2.1"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" +TEXT_VER="1.2.2.2"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.3 -NETWORK_VER="2.6.3.1"; NETWORK_VER_REGEXP="2\.[0-6]\." +NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\." # >= 2.0 && < 2.7 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\." # >= 2.6 && < 2.7 -CABAL_VER="1.24.2.0"; CABAL_VER_REGEXP="1\.24\.[2-9]" - # >= 1.24.2 && < 1.25 -TRANS_VER="0.5.2.0"; TRANS_VER_REGEXP="0\.[45]\." +CABAL_VER="2.0.0.2"; CABAL_VER_REGEXP="2\.0\.[0-9]" + # >= 2.0 && < 2.1 +TRANS_VER="0.5.4.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.1"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 -HTTP_VER="4000.3.3"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" +HTTP_VER="4000.3.7"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 ZLIB_VER="0.6.1.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 -TIME_VER="1.7" TIME_VER_REGEXP="1\.[1-7]\.?" - # >= 1.1 && < 1.8 +TIME_VER="1.8.0.2" TIME_VER_REGEXP="1\.[1-8]\.?" + # >= 1.1 && < 1.9 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 STM_VER="2.4.4.1"; STM_VER_REGEXP="2\." # == 2.* -ASYNC_VER="2.1.0"; ASYNC_VER_REGEXP="2\." +ASYNC_VER="2.1.1.1"; ASYNC_VER_REGEXP="2\." # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?" # >=1.0.0.0 && <1.2 @@ -249,10 +257,16 @@ # >=1.0.0.0 && <1.1 BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1" # 0.1.* -BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_REGEXP="1\." +BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." # >=1.0 CRYPTOHASH_SHA256_VER="0.11.100.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" # 0.11.* +MINTTY_VER="0.1"; MINTTY_VER_REGEXP="0\.1\.?" + # 0.1.* +ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" + # >= 0.1.3 && < 0.2 +EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?" + # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.* HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])" @@ -260,7 +274,7 @@ BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?" TAR_VER="0.5.0.3"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 -HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\." +HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\." # 1.* HACKAGE_URL="https://hackage.haskell.org/package" @@ -354,7 +368,7 @@ [ -x Setup ] && ./Setup clean [ -f Setup ] && rm Setup - ${GHC} --make ${JOBS} Setup -o Setup || + ${GHC} --make ${JOBS} Setup -o Setup -XRank2Types -XFlexibleContexts || die "Compiling the Setup script failed." [ -x Setup ] || die "The Setup script does not exist or cannot be run" @@ -399,10 +413,8 @@ echo "Downloading ${PKG}-${VER}..." fetch_pkg ${PKG} ${VER} fi - unpack_pkg ${PKG} ${VER} - cd "${PKG}-${VER}" - install_pkg ${PKG} ${VER} - cd .. + unpack_pkg "${PKG}" "${VER}" + (cd "${PKG}-${VER}" && install_pkg ${PKG} ${VER}) fi } @@ -414,9 +426,7 @@ if need_pkg "Cabal" ${CABAL_VER_REGEXP} then echo "Cabal-${CABAL_VER} will be installed from the local Git clone." - cd ../Cabal - install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP} - cd ../cabal-install + (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP}) else echo "Cabal is already installed and the version is ok." fi @@ -481,6 +491,9 @@ ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +info_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} +info_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} +info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} @@ -516,6 +529,9 @@ ${BASE64_BYTESTRING_VER_REGEXP} do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +do_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} +do_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} +do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} # We conditionally install bytestring-builder, depending on the bytestring 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.24.0.2 +Version: 2.0.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -9,17 +9,9 @@ bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE -Author: Lemmih - Paolo Martini - Bjorn Bringert - Isaac Potoczny-Jones - Duncan Coutts -Maintainer: cabal-devel@haskell.org -Copyright: 2005 Lemmih - 2006 Paolo Martini - 2007 Bjorn Bringert - 2007 Isaac Potoczny-Jones - 2007-2012 Duncan Coutts +Author: Cabal Development Team (see AUTHORS file) +Maintainer: Cabal Development Team +Copyright: 2003-2017, Cabal Development Team Category: Distribution Build-type: Custom Cabal-Version: >= 1.10 @@ -30,98 +22,67 @@ -- Generated with '../Cabal/misc/gen-extra-source-files.sh' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files - tests/IntegrationTests/custom-setup/common.sh - tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal - tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs - tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal - tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs - tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs - tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal - tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs - tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal - tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs - tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal - tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh - tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh - tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh - tests/IntegrationTests/custom/common.sh - tests/IntegrationTests/custom/should_run/plain.err - tests/IntegrationTests/custom/should_run/plain.sh - tests/IntegrationTests/custom/should_run/plain/A.hs - tests/IntegrationTests/custom/should_run/plain/Setup.hs - tests/IntegrationTests/custom/should_run/plain/plain.cabal - tests/IntegrationTests/exec/common.sh - tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err - tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh - tests/IntegrationTests/exec/should_run/Foo.hs - tests/IntegrationTests/exec/should_run/My.hs - tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out - tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh - tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out - tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh - tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out - tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh - tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh - tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh - tests/IntegrationTests/exec/should_run/my.cabal - tests/IntegrationTests/exec/should_run/runs_given_command.out - tests/IntegrationTests/exec/should_run/runs_given_command.sh - tests/IntegrationTests/freeze/common.sh - tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh - tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh - tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh - tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh - tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh - tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh - tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh - tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh - tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh - tests/IntegrationTests/freeze/should_run/my.cabal - tests/IntegrationTests/freeze/should_run/runs_without_error.sh - tests/IntegrationTests/manpage/common.sh - tests/IntegrationTests/manpage/should_run/outputs_manpage.sh - tests/IntegrationTests/multiple-source/common.sh - tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh - tests/IntegrationTests/multiple-source/should_run/p/Setup.hs - tests/IntegrationTests/multiple-source/should_run/p/p.cabal - tests/IntegrationTests/multiple-source/should_run/q/Setup.hs - tests/IntegrationTests/multiple-source/should_run/q/q.cabal - tests/IntegrationTests/new-build/monitor_cabal_files.sh - tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs - tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs - tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal - tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs - tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs - tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in - tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in - tests/IntegrationTests/regression/common.sh - tests/IntegrationTests/regression/t3199.sh - tests/IntegrationTests/regression/t3199/Main.hs - tests/IntegrationTests/regression/t3199/Setup.hs - tests/IntegrationTests/regression/t3199/test-3199.cabal - tests/IntegrationTests/sandbox-sources/common.sh - tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err - tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh - tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs - tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal - tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs - tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal - tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs - tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal - tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs - tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal - tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh - tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out - tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh - tests/IntegrationTests/user-config/common.sh - tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err - tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh - tests/IntegrationTests/user-config/should_run/overwrites_with_f.out - tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh - tests/IntegrationTests/user-config/should_run/runs_without_error.out - tests/IntegrationTests/user-config/should_run/runs_without_error.sh - tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out - tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh + tests/IntegrationTests2/build/keep-going/cabal.project + tests/IntegrationTests2/build/keep-going/p/P.hs + tests/IntegrationTests2/build/keep-going/p/p.cabal + tests/IntegrationTests2/build/keep-going/q/Q.hs + tests/IntegrationTests2/build/keep-going/q/q.cabal + tests/IntegrationTests2/build/setup-custom1/A.hs + tests/IntegrationTests2/build/setup-custom1/Setup.hs + tests/IntegrationTests2/build/setup-custom1/a.cabal + tests/IntegrationTests2/build/setup-custom2/A.hs + tests/IntegrationTests2/build/setup-custom2/Setup.hs + tests/IntegrationTests2/build/setup-custom2/a.cabal + tests/IntegrationTests2/build/setup-simple/A.hs + tests/IntegrationTests2/build/setup-simple/Setup.hs + tests/IntegrationTests2/build/setup-simple/a.cabal + tests/IntegrationTests2/exception/bad-config/cabal.project + tests/IntegrationTests2/exception/build/Main.hs + tests/IntegrationTests2/exception/build/a.cabal + tests/IntegrationTests2/exception/configure/a.cabal + tests/IntegrationTests2/exception/no-pkg/empty.in + tests/IntegrationTests2/exception/no-pkg2/cabal.project + tests/IntegrationTests2/regression/3324/cabal.project + tests/IntegrationTests2/regression/3324/p/P.hs + tests/IntegrationTests2/regression/3324/p/p.cabal + tests/IntegrationTests2/regression/3324/q/Q.hs + tests/IntegrationTests2/regression/3324/q/q.cabal + tests/IntegrationTests2/targets/all-disabled/cabal.project + tests/IntegrationTests2/targets/all-disabled/p.cabal + tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project + tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal + tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal + tests/IntegrationTests2/targets/complex/cabal.project + tests/IntegrationTests2/targets/complex/q/Q.hs + tests/IntegrationTests2/targets/complex/q/q.cabal + tests/IntegrationTests2/targets/empty-pkg/cabal.project + tests/IntegrationTests2/targets/empty-pkg/p.cabal + tests/IntegrationTests2/targets/empty/cabal.project + tests/IntegrationTests2/targets/empty/foo.hs + tests/IntegrationTests2/targets/exes-disabled/cabal.project + tests/IntegrationTests2/targets/exes-disabled/p/p.cabal + tests/IntegrationTests2/targets/exes-disabled/q/q.cabal + tests/IntegrationTests2/targets/libs-disabled/cabal.project + tests/IntegrationTests2/targets/libs-disabled/p/p.cabal + tests/IntegrationTests2/targets/libs-disabled/q/q.cabal + tests/IntegrationTests2/targets/multiple-exes/cabal.project + tests/IntegrationTests2/targets/multiple-exes/p.cabal + tests/IntegrationTests2/targets/multiple-libs/cabal.project + tests/IntegrationTests2/targets/multiple-libs/p/p.cabal + tests/IntegrationTests2/targets/multiple-libs/q/q.cabal + tests/IntegrationTests2/targets/multiple-tests/cabal.project + tests/IntegrationTests2/targets/multiple-tests/p.cabal + tests/IntegrationTests2/targets/simple/P.hs + tests/IntegrationTests2/targets/simple/cabal.project + tests/IntegrationTests2/targets/simple/p.cabal + tests/IntegrationTests2/targets/simple/q/QQ.hs + tests/IntegrationTests2/targets/simple/q/q.cabal + tests/IntegrationTests2/targets/test-only/p.cabal + tests/IntegrationTests2/targets/tests-disabled/cabal.project + tests/IntegrationTests2/targets/tests-disabled/p.cabal + tests/IntegrationTests2/targets/tests-disabled/q/q.cabal + tests/IntegrationTests2/targets/variety/cabal.project + tests/IntegrationTests2/targets/variety/p.cabal -- END gen-extra-source-files source-repository head @@ -141,55 +102,65 @@ description: Get Network.URI from the network-uri package default: True +Flag debug-expensive-assertions + description: Enable expensive assertions for testing or debugging + default: False + manual: True + +Flag debug-conflict-sets + description: Add additional information to ConflictSets + default: False + manual: True + +Flag debug-tracetree + description: Compile in support for tracetree (used to debug the solver) + default: False + manual: True + +flag parsec + description: Use parsec parser. This requires 'Cabal' library built with its parsec flag enabled. + default: False + manual: True + +-- When we do CI, we build our binaries on one machine, and then +-- ship them to another machine for testing. Because we use +-- static linking (since it makes this sort of redeploy MUCH +-- easier), if we build five executables, that means we +-- need to ship ALL the Haskell libraries five times. That's +-- a waste of space! A better strategy is to statically link +-- everything into a single binary. That's what this flag does. +flag monolithic + description: Build cabal-install also with all of its test and support code. Used by our continuous integration. + default: False + manual: True + executable cabal main-is: Main.hs - ghc-options: -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs -rtsopts if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances other-modules: - Distribution.Client.BuildTarget Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types Distribution.Client.BuildReports.Upload Distribution.Client.Check + Distribution.Client.CmdBench Distribution.Client.CmdBuild Distribution.Client.CmdConfigure + Distribution.Client.CmdFreeze + Distribution.Client.CmdHaddock Distribution.Client.CmdRepl - Distribution.Client.ComponentDeps + Distribution.Client.CmdRun + Distribution.Client.CmdTest + Distribution.Client.CmdErrorMessages Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency - Distribution.Client.Dependency.TopDown - Distribution.Client.Dependency.TopDown.Constraints - Distribution.Client.Dependency.TopDown.Types Distribution.Client.Dependency.Types - Distribution.Client.Dependency.Modular - Distribution.Client.Dependency.Modular.Assignment - Distribution.Client.Dependency.Modular.Builder - Distribution.Client.Dependency.Modular.Configured - Distribution.Client.Dependency.Modular.ConfiguredConversion - Distribution.Client.Dependency.Modular.ConflictSet - Distribution.Client.Dependency.Modular.Cycles - Distribution.Client.Dependency.Modular.Dependency - Distribution.Client.Dependency.Modular.Explore - Distribution.Client.Dependency.Modular.Flag - Distribution.Client.Dependency.Modular.Index - Distribution.Client.Dependency.Modular.IndexConversion - Distribution.Client.Dependency.Modular.Linking - Distribution.Client.Dependency.Modular.Log - Distribution.Client.Dependency.Modular.Message - Distribution.Client.Dependency.Modular.Package - Distribution.Client.Dependency.Modular.Preference - Distribution.Client.Dependency.Modular.PSQ - Distribution.Client.Dependency.Modular.Solver - Distribution.Client.Dependency.Modular.Tree - Distribution.Client.Dependency.Modular.Validate - Distribution.Client.Dependency.Modular.Var - Distribution.Client.Dependency.Modular.Version Distribution.Client.DistDirLayout Distribution.Client.Exec Distribution.Client.Fetch @@ -204,6 +175,7 @@ Distribution.Client.Haddock Distribution.Client.HttpUtils Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init Distribution.Client.Init.Heuristics Distribution.Client.Init.Licenses @@ -214,13 +186,13 @@ Distribution.Client.JobControl Distribution.Client.List Distribution.Client.Manpage + Distribution.Client.Nix + Distribution.Client.Outdated Distribution.Client.PackageHash - Distribution.Client.PackageIndex Distribution.Client.PackageUtils Distribution.Client.ParseUtils - Distribution.Client.PkgConfigDb - Distribution.Client.PlanIndex Distribution.Client.ProjectBuilding + Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectConfig.Legacy @@ -228,32 +200,87 @@ Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.Types Distribution.Client.ProjectPlanOutput - Distribution.Client.Run Distribution.Client.RebuildMonad + Distribution.Client.Reconfigure + Distribution.Client.Run Distribution.Client.Sandbox Distribution.Client.Sandbox.Index Distribution.Client.Sandbox.PackageEnvironment Distribution.Client.Sandbox.Timestamp Distribution.Client.Sandbox.Types + Distribution.Client.SavedFlags + Distribution.Client.Security.DNS Distribution.Client.Security.HTTP Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist + Distribution.Client.SolverInstallPlan + Distribution.Client.SourceFiles + Distribution.Client.Store Distribution.Client.Tar Distribution.Client.Targets + Distribution.Client.TargetSelector Distribution.Client.Types Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils - Distribution.Client.Utils.LabeledGraph + Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json Distribution.Client.World Distribution.Client.Win32SelfUpgrade Distribution.Client.Compat.ExecutablePath + Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore - Distribution.Client.Compat.Time + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable + Distribution.Solver.Modular + Distribution.Solver.Modular.Assignment + Distribution.Solver.Modular.Builder + Distribution.Solver.Modular.Configured + Distribution.Solver.Modular.ConfiguredConversion + Distribution.Solver.Modular.ConflictSet + Distribution.Solver.Modular.Cycles + Distribution.Solver.Modular.Dependency + Distribution.Solver.Modular.Explore + Distribution.Solver.Modular.Flag + Distribution.Solver.Modular.Index + Distribution.Solver.Modular.IndexConversion + Distribution.Solver.Modular.Linking + Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Log + Distribution.Solver.Modular.Message + Distribution.Solver.Modular.Package + Distribution.Solver.Modular.Preference + Distribution.Solver.Modular.PSQ + Distribution.Solver.Modular.RetryLog + Distribution.Solver.Modular.Solver + Distribution.Solver.Modular.Tree + Distribution.Solver.Modular.Validate + Distribution.Solver.Modular.Var + Distribution.Solver.Modular.Version + Distribution.Solver.Modular.WeightedPSQ Paths_cabal_install -- NOTE: when updating build-depends, don't forget to update version regexps @@ -265,9 +292,12 @@ base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.5 && < 0.9, bytestring >= 0.9 && < 1, - Cabal >= 1.24.2 && < 1.25, + Cabal >= 2.0 && < 2.1, containers >= 0.4 && < 0.6, cryptohash-sha256 >= 0.11 && < 0.12, + deepseq >= 1.3 && < 1.5, + echo >= 0.1.3 && < 0.2, + edit-distance >= 0.2.2 && < 0.3, filepath >= 1.3 && < 1.5, hashable >= 1.0 && < 2, HTTP >= 4000.1.5 && < 4000.4, @@ -276,7 +306,7 @@ random >= 1 && < 1.2, stm >= 2.0 && < 3, tar >= 0.5.0.3 && < 0.6, - time >= 1.4 && < 1.8, + time >= 1.4 && < 1.9, zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6 @@ -290,7 +320,7 @@ process >= 1.0.1.1 && < 1.1.0.2 else build-depends: directory >= 1.2 && < 1.4, - process >= 1.1.0.2 && < 1.5 + process >= 1.1.0.2 && < 1.7 -- NOTE: you MUST include the network dependency even when network-uri -- is pulled in, otherwise the constraint solver doesn't have enough @@ -309,13 +339,83 @@ else build-depends: unix >= 2.5 && < 2.8 - if arch(arm) && impl(ghc < 7.6) - -- older ghc on arm does not support -threaded - cc-options: -DCABAL_NO_THREADED - else - ghc-options: -threaded + if !(arch(arm) && impl(ghc < 7.6)) + ghc-options: -threaded - c-sources: cbits/getnumcores.c + -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a + if os(aix) + extra-libraries: bsd + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + + if flag(parsec) + cpp-options: -DCABAL_PARSEC + + hs-source-dirs: . + if flag(monolithic) + hs-source-dirs: tests + other-modules: + UnitTests + UnitTests.Distribution.Client.ArbitraryInstances + UnitTests.Distribution.Client.FileMonitor + UnitTests.Distribution.Client.GZipUtils + UnitTests.Distribution.Client.Glob + UnitTests.Distribution.Client.IndexUtils.Timestamp + UnitTests.Distribution.Client.InstallPlan + UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Client.Sandbox + UnitTests.Distribution.Client.Sandbox.Timestamp + UnitTests.Distribution.Client.Store + UnitTests.Distribution.Client.Tar + UnitTests.Distribution.Client.Targets + UnitTests.Distribution.Client.UserConfig + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.MemoryUsage + UnitTests.Distribution.Solver.Modular.PSQ + UnitTests.Distribution.Solver.Modular.QuickCheck + UnitTests.Distribution.Solver.Modular.RetryLog + UnitTests.Distribution.Solver.Modular.Solver + UnitTests.Distribution.Solver.Modular.WeightedPSQ + UnitTests.Options + MemoryUsageTests + SolverQuickCheck + IntegrationTests2 + cpp-options: -DMONOLITHIC + build-depends: + Cabal >= 2.0 && < 2.1, + QuickCheck >= 2.8.2, + array, + async, + bytestring, + containers, + deepseq, + directory, + edit-distance, + filepath, + mtl, + network, + network-uri, + pretty-show, + random, + tagged, + tar, + tasty, + tasty-hunit, + tasty-quickcheck, + time, + zlib + default-language: Haskell2010 -- Small, fast running tests. @@ -323,29 +423,39 @@ type: exitcode-stdio-1.0 main-is: UnitTests.hs hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs -main-is UnitTests other-modules: + Distribution.Client.Compat.FileLock UnitTests.Distribution.Client.ArbitraryInstances - UnitTests.Distribution.Client.Targets - UnitTests.Distribution.Client.Compat.Time - UnitTests.Distribution.Client.Dependency.Modular.PSQ - UnitTests.Distribution.Client.Dependency.Modular.Solver - UnitTests.Distribution.Client.Dependency.Modular.DSL UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.Glob UnitTests.Distribution.Client.GZipUtils + UnitTests.Distribution.Client.Glob + UnitTests.Distribution.Client.IndexUtils.Timestamp + UnitTests.Distribution.Client.InstallPlan + UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.ProjectConfig UnitTests.Distribution.Client.Sandbox UnitTests.Distribution.Client.Sandbox.Timestamp + UnitTests.Distribution.Client.Store UnitTests.Distribution.Client.Tar + UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.PSQ + UnitTests.Distribution.Solver.Modular.RetryLog + UnitTests.Distribution.Solver.Modular.Solver + UnitTests.Distribution.Solver.Modular.WeightedPSQ UnitTests.Options + build-depends: base, + async, array, bytestring, Cabal, containers, + deepseq, mtl, pretty, process, @@ -382,37 +492,224 @@ else build-depends: unix - if arch(arm) - cc-options: -DCABAL_NO_THREADED + ghc-options: -fno-ignore-asserts + + if !(arch(arm) && impl(ghc < 7.6)) + ghc-options: -threaded + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + + default-language: Haskell2010 + +-- Tests to run with a limited stack and heap size +Test-Suite memory-usage-tests + type: exitcode-stdio-1.0 + main-is: MemoryUsageTests.hs + hs-source-dirs: tests, . + ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests + other-modules: + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.MemoryUsage + UnitTests.Options + build-depends: + base, + async, + array, + bytestring, + Cabal, + containers, + deepseq, + mtl, + pretty, + process, + directory, + filepath, + hashable, + stm, + tar, + time, + HTTP, + zlib, + binary, + random, + hackage-security, + tagged, + tasty, + tasty-hunit + + if flag(old-directory) + build-depends: old-time + + if flag(network-uri) + build-depends: network-uri >= 2.6, network >= 2.6 else + build-depends: network-uri < 2.6, network < 2.6 + + if impl(ghc < 7.6) + build-depends: ghc-prim >= 0.2 && < 0.3 + + if os(windows) + build-depends: Win32 + else + build-depends: unix + + ghc-options: -fno-ignore-asserts + + if !(arch(arm) && impl(ghc < 7.6)) ghc-options: -threaded + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + default-language: Haskell2010 -test-suite integration-tests +-- Slow solver tests +Test-Suite solver-quickcheck type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: IntegrationTests.hs + main-is: SolverQuickCheck.hs + hs-source-dirs: tests, . + ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is SolverQuickCheck + other-modules: + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.QuickCheck build-depends: - Cabal, - async, - base, - bytestring, - directory, - filepath, - process, - regex-posix, - tasty, - tasty-hunit + base, + async, + array, + bytestring, + Cabal, + containers, + deepseq >= 1.2, + mtl, + pretty, + process, + directory, + filepath, + hashable, + stm, + tar, + time, + HTTP, + zlib, + binary, + random, + hackage-security, + tasty, + tasty-quickcheck, + QuickCheck >= 2.8.2, + pretty-show + if flag(old-directory) + build-depends: old-time + + if flag(network-uri) + build-depends: network-uri >= 2.6, network >= 2.6 + else + build-depends: network-uri < 2.6, network < 2.6 + + if impl(ghc < 7.6) + build-depends: ghc-prim >= 0.2 && < 0.3 + if os(windows) - build-depends: Win32 >= 2 && < 3 + build-depends: Win32 else - build-depends: unix >= 2.5 && < 2.8 + build-depends: unix + if !(arch(arm) && impl(ghc < 7.6)) + ghc-options: -threaded + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + + default-language: Haskell2010 + +-- Integration tests that use the cabal-install code directly +-- but still build whole projects +test-suite integration-tests2 + type: exitcode-stdio-1.0 + main-is: IntegrationTests2.hs + hs-source-dirs: tests, . + ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is IntegrationTests2 + other-modules: Distribution.Client.Compat.FileLock + build-depends: + async, + array, + base, + base16-bytestring, + binary, + bytestring, + Cabal, + containers, + cryptohash-sha256, + deepseq, + directory, + edit-distance, + filepath, + hackage-security, + hashable, + HTTP, + mtl, + network, + network-uri, + pretty, + process, + random, + stm, + tar, + time, + zlib, + tasty, + tasty-hunit, + tagged + + if flag(old-bytestring) + build-depends: bytestring-builder + + if flag(old-directory) + build-depends: old-time + + if impl(ghc < 7.6) + build-depends: ghc-prim >= 0.2 && < 0.3 + + if os(windows) + build-depends: Win32 + else + build-depends: unix + if arch(arm) cc-options: -DCABAL_NO_THREADED else ghc-options: -threaded - - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts default-language: Haskell2010 + +custom-setup + setup-depends: Cabal >= 2.0, + base, + process >= 1.1.0.1 && < 1.7, + filepath >= 1.3 && < 1.5 diff --git a/cbits/getnumcores.c b/cbits/getnumcores.c deleted file mode 100644 --- a/cbits/getnumcores.c +++ /dev/null @@ -1,46 +0,0 @@ -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612) && !defined(CABAL_NO_THREADED) -/* Since version 6.12, GHC's threaded RTS includes a getNumberOfProcessors - function, so we try to use that if available. cabal-install is always built - with -threaded nowadays. */ -#define HAS_GET_NUMBER_OF_PROCESSORS -#endif - - -#ifndef HAS_GET_NUMBER_OF_PROCESSORS - -#if defined(_WIN32) && !defined(__CYGWIN__) -#include -#elif MACOS -#include -#include -#elif __linux__ -#include -#endif - -int getNumberOfProcessors() { -#if defined(_WIN32) && !defined(__CYGWIN__) - SYSTEM_INFO sysinfo; - GetSystemInfo(&sysinfo); - return sysinfo.dwNumberOfProcessors; -#elif MACOS - int nm[2]; - size_t len = 4; - uint32_t count; - - nm[0] = CTL_HW; nm[1] = HW_AVAILCPU; - sysctl(nm, 2, &count, &len, NULL, 0); - - if(count < 1) { - nm[1] = HW_NCPU; - sysctl(nm, 2, &count, &len, NULL, 0); - if(count < 1) { count = 1; } - } - return count; -#elif __linux__ - return sysconf(_SC_NPROCESSORS_ONLN); -#else - return 1; -#endif -} - -#endif /* HAS_GET_NUMBER_OF_PROCESSORS */ diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,28 +1,53 @@ -*-change-log-*- -1.24.0.2 Mikhail Glushenkov December 2016 - * Adapted to the revert of a PVP-noncompliant API change in - Cabal 1.24.2.0 (#4123). - * Bumped the directory upper bound to < 1.4 (#4158). -1.24.0.1 Ryan Thomas October 2016 - * Fixed issue with passing '--enable-profiling' when invoking - Setup scripts built with older versions of Cabal (#3873). +2.0.0.0 Mikhail Glushenkov August 2017 + * Removed the '--root-cmd' parameter of the 'install' command + (#3356). + * Deprecated 'cabal install --global' (#3356). + * Changed 'cabal upload' to upload a package candidate by default + (#3419). Same applies to uploading documentation. + * Added a new 'cabal upload' flag '--publish' for publishing a + package on Hackage instead of uploading a candidate (#3419). + * Added optional solver output visualisation support via the + tracetree package. Mainly intended for debugging (#3410). + * Removed the '--check' option from 'cabal upload' + (#1823). It was replaced by package candidates. * Fixed various behaviour differences between network transports (#3429). - * Updated to depend on the latest hackage-security that fixes - various issues on Windows. - * Fixed 'new-build' to exit with a non-zero exit code on failure - (#3506). - * Store secure repo index data as 01-index.* (#3862). - * Added new hackage-security root keys for distribution with - cabal-install. - * Fix an issue where 'cabal install' sometimes had to be run twice - for packages with build-type: Custom and a custom-setup stanza - (#3723). - * 'cabal sdist' no longer ignores '--builddir' when the package's - build-type is Custom (#3794). + * The bootstrap script now works correctly when run from a Git + clone (#3439). + * Removed the top-down solver (#3598). + * The '-v/--verbosity' option no longer affects GHC verbosity + (except in the case of '-v0'). Use '--ghc-options=-v' to enable + verbose GHC output (#3540, #3671). + * Changed the default logfile template from + '.../$pkgid.log' to '.../$compiler/$libname.log' (#3807). + * Added a new command, 'cabal reconfigure', which re-runs 'configure' + with the most recently used flags (#2214). + * Added add the '--index-state' flag for requesting a specific + version of the package index (#3893, #4115). + * Support for building Backpack packages. See + https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst + for more details. + * Support the Nix package manager (#3651). + * Made the 'template-haskell' package non-upgradable again (#4185). + * Fixed password echoing on MinTTY (#4128). + * Added a new solver flag, '--install-base-libraries', that allows + any package to be installed or upgraded (#4209). + * New 'cabal-install' command: 'outdated', for listing outdated + version bounds in a .cabal file or a freeze file (#4207). + * Added qualified constraints for setup dependencies. For example, + --constraint="setup.bar == 1.0" constrains all setup dependencies on + bar, and --constraint="foo:setup.bar == 1.0" constrains foo's setup + dependency on bar (part of #3502). + * Non-qualified constraints, such as --constraint="bar == 1.0", now + only apply to top-level dependencies. They don't constrain setup or + build-tool dependencies. The new syntax --constraint="any.bar == 1.0" + constrains all uses of bar. + * Added a technical preview version of the 'cabal doctest' command + (#4480). -1.24.0.0 Ryan Thomas May 2016 +1.24.0.0 Ryan Thomas March 2016 * If there are multiple remote repos, 'cabal update' now updates them in parallel (#2503). * New 'cabal upload' option '-P'/'--password-command' for reading @@ -187,7 +212,7 @@ * HTTP-4000 package required, should fix bugs with http proxies * Now works with authenticated proxies. * On Windows can now override the proxy setting using an env var - * Fix compatability with config files generated by older versions + * Fix compatibility with config files generated by older versions * Warn if the hackage package list is very old * More helpful --help output, mention config file and examples * Better documentation in ~/.cabal/config file @@ -244,7 +269,7 @@ 0.4 Duncan Coutts Oct 2007 * Renamed executable from 'cabal-install' to 'cabal' - * Partial Windows compatability + * Partial Windows compatibility * Do per-user installs by default * cabal install now installs the package in the current directory * Allow multiple remote servers diff --git a/tests/IntegrationTests.hs b/tests/IntegrationTests.hs deleted file mode 100644 --- a/tests/IntegrationTests.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Groups black-box tests of cabal-install and configures them to test --- the correct binary. --- --- This file should do nothing but import tests from other modules and run --- them with the path to the correct cabal-install binary. -module Main - where - --- Modules from Cabal. -import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Compat.Environment (setEnv) -import Distribution.Compat.Internal.TempFile (createTempDirectory) -import Distribution.Simple.Configure (findDistPrefOrDefault) -import Distribution.Simple.Program.Builtin (ghcPkgProgram) -import Distribution.Simple.Program.Db - (defaultProgramDb, requireProgram, setProgramSearchPath) -import Distribution.Simple.Program.Find - (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath) -import Distribution.Simple.Program.Types - ( Program(..), simpleProgram, programPath) -import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Simple.Utils ( findProgramVersion, copyDirectoryRecursive ) -import Distribution.Verbosity (normal) - --- Third party modules. -import Control.Concurrent.Async (withAsync, wait) -import Control.Exception (bracket) -import Data.Maybe (fromMaybe) -import System.Directory - ( canonicalizePath - , findExecutable - , getDirectoryContents - , getTemporaryDirectory - , doesDirectoryExist - , removeDirectoryRecursive - , doesFileExist ) -import System.FilePath -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (testCase, Assertion, assertFailure) -import Control.Monad ( filterM, forM, unless, when ) -import Data.List (isPrefixOf, isSuffixOf, sort) -import Data.IORef (newIORef, writeIORef, readIORef) -import System.Exit (ExitCode(..)) -import System.IO (withBinaryFile, IOMode(ReadMode)) -import System.Process (runProcess, waitForProcess) -import Text.Regex.Posix ((=~)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import Data.ByteString (ByteString) - -#if MIN_VERSION_base(4,6,0) -import System.Environment ( getExecutablePath ) -#endif - --- | Test case. -data TestCase = TestCase - { tcName :: String -- ^ Name of the shell script - , tcBaseDirectory :: FilePath - , tcCategory :: String - , tcShouldX :: String - , tcStdOutPath :: Maybe FilePath -- ^ File path of "golden standard output" - , tcStdErrPath :: Maybe FilePath -- ^ File path of "golden standard error" - } - --- | Test result. -data TestResult = TestResult - { trExitCode :: ExitCode - , trStdOut :: ByteString - , trStdErr :: ByteString - , trWorkingDirectory :: FilePath - } - --- | Cabal executable -cabalProgram :: Program -cabalProgram = (simpleProgram "cabal") { - programFindVersion = findProgramVersion "--numeric-version" id - } - --- | Convert test result to string. -testResultToString :: TestResult -> String -testResultToString testResult = - exitStatus ++ "\n" ++ workingDirectory ++ "\n\n" ++ stdOut ++ "\n\n" ++ stdErr - where - exitStatus = "Exit status: " ++ show (trExitCode testResult) - workingDirectory = "Working directory: " ++ (trWorkingDirectory testResult) - stdOut = " 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-setup/common.sh b/tests/IntegrationTests/custom-setup/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# Helper to run Cabal -cabal() { - "$CABAL" $CABAL_ARGS "$@" -} - -die() { - echo "die: $@" - exit 1 -} diff --git a/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal b/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/Cabal.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: Cabal -version: 99998 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: CabalMessage diff --git a/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs b/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/Cabal-99998/CabalMessage.hs +++ /dev/null @@ -1,3 +0,0 @@ -module CabalMessage where - -message = "This is Cabal-99998" diff --git a/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal b/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/Cabal.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: Cabal -version: 99999 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: CabalMessage diff --git a/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs b/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/Cabal-99999/CabalMessage.hs +++ /dev/null @@ -1,3 +0,0 @@ -module CabalMessage where - -message = "This is Cabal-99999" diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs b/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal b/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup-without-cabal-defaultMain -version: 1.0 -build-type: Custom -cabal-version: >= 1.2 - -custom-setup - setup-depends: base - -library diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs b/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -import System.Exit -import System.IO - -main = hPutStrLn stderr "My custom Setup" >> exitFailure diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal b/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup-without-cabal/custom-setup-without-cabal.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup-without-cabal -version: 1.0 -build-type: Custom -cabal-version: >= 99999 - -custom-setup - setup-depends: base - -library diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs b/tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -import CabalMessage (message) -import System.Exit -import System.IO - -main = hPutStrLn stderr message >> exitFailure diff --git a/tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal b/tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom-setup/custom-setup.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup -version: 1.0 -build-type: Custom -cabal-version: >= 99999 - -custom-setup - setup-depends: base, Cabal >= 99999 - -library diff --git a/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh b/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh +++ /dev/null @@ -1,12 +0,0 @@ -. ../common.sh -cd custom-setup-without-cabal-defaultMain - -# This package has explicit setup dependencies that do not include Cabal. -# Compilation should fail because Setup.hs imports Distribution.Simple. -! cabal new-build custom-setup-without-cabal-defaultMain > output 2>&1 -cat output -grep -q "\(Could not find module\|Failed to load interface for\).*Distribution\\.Simple" output \ - || die "Should not have been able to import Cabal" - -grep -q "It is a member of the hidden package .*Cabal-" output \ - || die "Cabal should be available" diff --git a/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh b/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/custom_setup_without_Cabal_doesnt_require_Cabal.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ../common.sh -cd custom-setup-without-cabal - -# This package has explicit setup dependencies that do not include Cabal. -# new-build should try to build it, even though the cabal-version cannot be -# satisfied by an installed version of Cabal (cabal-version: >= 99999). However, -# configure should fail because Setup.hs just prints an error message and exits. -! cabal new-build custom-setup-without-cabal > output 2>&1 -cat output -grep -q "My custom Setup" output \ - || die "Expected output from custom Setup" diff --git a/tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh b/tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom-setup/should_run/installs_Cabal_as_setup_dep.sh +++ /dev/null @@ -1,15 +0,0 @@ -# Regression test for issue #3436 - -. ../common.sh -cabal sandbox init -cabal install ./Cabal-99998 -cabal sandbox add-source Cabal-99999 - -# Install custom-setup, which has a setup dependency on Cabal-99999. -# cabal should build the setup script with Cabal-99999, but then -# configure should fail because Setup just prints an error message -# imported from Cabal and exits. -! cabal install custom-setup/ > output 2>&1 - -cat output -grep -q "This is Cabal-99999" output || die "Expected output from Cabal-99999" diff --git a/tests/IntegrationTests/custom/common.sh b/tests/IntegrationTests/custom/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/custom/should_run/plain.err +++ /dev/null @@ -1,2 +0,0 @@ -Custom -Custom diff --git a/tests/IntegrationTests/custom/should_run/plain.sh b/tests/IntegrationTests/custom/should_run/plain.sh deleted file mode 100644 --- a/tests/IntegrationTests/custom/should_run/plain.sh +++ /dev/null @@ -1,4 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/custom/should_run/plain/A.hs +++ /dev/null @@ -1,1 +0,0 @@ -module A where diff --git a/tests/IntegrationTests/custom/should_run/plain/Setup.hs b/tests/IntegrationTests/custom/should_run/plain/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/custom/should_run/plain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/custom/should_run/plain/plain.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: plain -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Custom -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/exec/common.sh b/tests/IntegrationTests/exec/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/exec/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.err +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../common.sh - -cabal exec diff --git a/tests/IntegrationTests/exec/should_run/Foo.hs b/tests/IntegrationTests/exec/should_run/Foo.hs deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/My.hs +++ /dev/null @@ -1,5 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.out +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/adds_sandbox_bin_directory_to_path.sh +++ /dev/null @@ -1,10 +0,0 @@ -. ../common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# Execute indirectly via bash to ensure that we go through $PATH -cabal exec sh -- -c my-executable || die "Did not find executable" diff --git a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.out +++ /dev/null @@ -1,4 +0,0 @@ -Config file path source is commandline option. -Config file config-file not found. -Writing default configuration to config-file -find_me_in_output diff --git a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh b/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/auto_configures_on_exec.sh +++ /dev/null @@ -1,2 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.out +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/can_run_executables_installed_in_sandbox.sh +++ /dev/null @@ -1,9 +0,0 @@ -. ../common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -cabal exec my-executable || die "Did not find executable" 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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/configures_cabal_to_use_sandbox.sh +++ /dev/null @@ -1,14 +0,0 @@ -. ../common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# The library should not be available outside the sandbox -"$GHC_PKG" list | grep -v "my-0.1" - -# When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command -# should find the library. -cabal exec sh -- -c 'cd subdir && "$CABAL" sandbox hc-pkg list' | grep "my-0.1" 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 deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/configures_ghc_to_use_sandbox.sh +++ /dev/null @@ -1,13 +0,0 @@ -. ../common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# The library should not be available outside the sandbox -"$GHC_PKG" list | grep -v "my-0.1" - -# Execute ghc-pkg inside the sandbox; it should find my-0.1 -cabal exec ghc-pkg list | grep "my-0.1" diff --git a/tests/IntegrationTests/exec/should_run/my.cabal b/tests/IntegrationTests/exec/should_run/my.cabal deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/my.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: my -version: 0.1 -license: BSD3 -cabal-version: >= 1.2 -build-type: Simple - -library - exposed-modules: Foo - build-depends: base - - -executable my-executable - main-is: My.hs - build-depends: base diff --git a/tests/IntegrationTests/exec/should_run/runs_given_command.out b/tests/IntegrationTests/exec/should_run/runs_given_command.out deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/runs_given_command.out +++ /dev/null @@ -1,1 +0,0 @@ -this string diff --git a/tests/IntegrationTests/exec/should_run/runs_given_command.sh b/tests/IntegrationTests/exec/should_run/runs_given_command.sh deleted file mode 100644 --- a/tests/IntegrationTests/exec/should_run/runs_given_command.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/disable_benchmarks_freezes_bench_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/disable_tests_freezes_test_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/does_not_freeze_nondeps.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ../common.sh -# TODO: Test this against a package installed in the sandbox but not -# depended upon. -cabal freeze -grep -v "exceptions ==" cabal.config || die "should not have frozen exceptions" diff --git a/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh b/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/does_not_freeze_self.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/dry_run_does_not_create_config.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/enable_benchmarks_freezes_bench_deps.sh +++ /dev/null @@ -1,4 +0,0 @@ -. ../common.sh -# TODO: solver should find solution without extra flags too -cabal freeze --enable-benchmarks --reorder-goals --max-backjumps=-1 -grep " criterion ==" cabal.config || die "should have frozen criterion" 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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/enable_tests_freezes_test_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/freezes_direct_dependencies.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/freezes_transitive_dependencies.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ../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 deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/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/IntegrationTests/freeze/should_run/runs_without_error.sh b/tests/IntegrationTests/freeze/should_run/runs_without_error.sh deleted file mode 100644 --- a/tests/IntegrationTests/freeze/should_run/runs_without_error.sh +++ /dev/null @@ -1,2 +0,0 @@ -. ../common.sh -cabal freeze diff --git a/tests/IntegrationTests/manpage/common.sh b/tests/IntegrationTests/manpage/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/manpage/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/manpage/should_run/outputs_manpage.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ../common.sh - -OUTPUT=`cabal manpage` - -# contains visible command descriptions -echo $OUTPUT | grep -q '\.B cabal install' || die "visible command description line not found in:\n----$OUTPUT\n----" - -# does not contain hidden command descriptions -echo $OUTPUT | grep -q '\.B cabal manpage' && die "hidden command description line found in:\n----$OUTPUT\n----" - -exit 0 diff --git a/tests/IntegrationTests/multiple-source/common.sh b/tests/IntegrationTests/multiple-source/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/common.sh +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/should_run/finds_second_source_of_multiple_source.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ../common.sh - -# Create the sandbox -cabal sandbox init - -# Add the sources -cabal sandbox add-source p -cabal sandbox add-source q - -# Install the second package -cabal install q diff --git a/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs b/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/should_run/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/should_run/p/p.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: p -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs b/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/should_run/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/multiple-source/should_run/q/q.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: q -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files.sh b/tests/IntegrationTests/new-build/monitor_cabal_files.sh deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files.sh +++ /dev/null @@ -1,8 +0,0 @@ -. ./common.sh -cd monitor_cabal_files -cp q/q-broken.cabal.in q/q.cabal -echo "Run 1" | awk '{print;print > "/dev/stderr"}' -! cabal new-build q -cp q/q-fixed.cabal.in q/q.cabal -echo "Run 2" | awk '{print;print > "/dev/stderr"}' -cabal new-build q diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: p -version: 1.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: P - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs b/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in +++ /dev/null @@ -1,12 +0,0 @@ -name: q -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -executable q - main-is: Main.hs - build-depends: base - default-language: Haskell2010 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 deleted file mode 100644 --- a/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in +++ /dev/null @@ -1,12 +0,0 @@ -name: q -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -executable q - main-is: Main.hs - build-depends: base, p - default-language: Haskell2010 diff --git a/tests/IntegrationTests/regression/common.sh b/tests/IntegrationTests/regression/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/regression/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/regression/t3199.sh +++ /dev/null @@ -1,12 +0,0 @@ -. ./common.sh - -if [[ `ghc --numeric-version` =~ "7\\." ]]; then - cd t3199 - tmpfile=$(mktemp /tmp/cabal-t3199.XXXXXX) - cabal sandbox init - cabal sandbox add-source ../../../../../Cabal - cabal install --package-db=clear --package-db=global --only-dep --dry-run > $tmpfile - grep -q "the following would be installed" $tmpfile || die "Should've installed Cabal" - grep -q Cabal $tmpfile || die "Should've installed Cabal" - rm $tmpfile -fi diff --git a/tests/IntegrationTests/regression/t3199/Main.hs b/tests/IntegrationTests/regression/t3199/Main.hs deleted file mode 100644 --- a/tests/IntegrationTests/regression/t3199/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/regression/t3199/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/tests/IntegrationTests/regression/t3199/test-3199.cabal b/tests/IntegrationTests/regression/t3199/test-3199.cabal deleted file mode 100644 --- a/tests/IntegrationTests/regression/t3199/test-3199.cabal +++ /dev/null @@ -1,27 +0,0 @@ -name: test-t3199 -version: 0.1.0.0 -license: BSD3 -author: Mikhail Glushenkov -maintainer: mikhail.glushenkov@gmail.com -category: Test -build-type: Custom -cabal-version: >=1.10 - -flag exe_2 - description: Build second exe - default: False - -executable test-3199-1 - main-is: Main.hs - build-depends: base - default-language: Haskell2010 - -executable test-3199-2 - main-is: Main.hs - build-depends: base, ansi-terminal - default-language: Haskell2010 - - if flag(exe_2) - buildable: True - else - buildable: False diff --git a/tests/IntegrationTests/sandbox-sources/common.sh b/tests/IntegrationTests/sandbox-sources/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/common.sh +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.sh +++ /dev/null @@ -1,10 +0,0 @@ -. ../common.sh - -# Create the sandbox -cabal sandbox init > /dev/null - -# Add one source -cabal sandbox add-source p > /dev/null - -# Remove a source that exists on disk, but is not registered -cabal sandbox delete-source q diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/p/p.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: p -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_fail/q/q.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: q -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/p/p.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: p -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs b/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/q/q.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: q -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh b/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/remove_nonexistent_source.sh +++ /dev/null @@ -1,22 +0,0 @@ -. ../common.sh - -# Create the sandbox -cabal sandbox init - -# Add the sources -cabal sandbox add-source p -cabal sandbox add-source q - -# delete the directory on disk -rm -R p - -# Remove the registered source which is no longer on disk. cabal's handling of -# non-existent sources depends on the behavior of the directory package. -if OUTPUT=`cabal sandbox delete-source p 2>&1`; then - # 'canonicalizePath' should always succeed with directory >= 1.2.3.0 - echo $OUTPUT | grep 'Success deleting sources: "p"' \ - || die "Incorrect success message: $OUTPUT" -else - echo $OUTPUT | grep 'Warning: Source directory not found for paths: "p"' \ - || die "Incorrect failure message: $OUTPUT" -fi 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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out +++ /dev/null @@ -1,6 +0,0 @@ -Success deleting sources: "p" "q" - -Note: 'sandbox delete-source' only unregisters the source dependency, but does -not remove the package from the sandbox package DB. - -Use 'sandbox hc-pkg -- unregister' to do that. 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 deleted file mode 100644 --- a/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ../common.sh - -# Create the sandbox -cabal sandbox init > /dev/null - -# Add the sources -cabal sandbox add-source p > /dev/null -cabal sandbox add-source q > /dev/null - -# Remove one of the sources -cabal sandbox delete-source p q diff --git a/tests/IntegrationTests/user-config/common.sh b/tests/IntegrationTests/user-config/common.sh deleted file mode 100644 --- a/tests/IntegrationTests/user-config/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# 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 deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.err +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_fail/doesnt_overwrite_without_f.sh +++ /dev/null @@ -1,6 +0,0 @@ -. ../common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init > /dev/null -cabal --config-file=./cabal-config user-config init -rm -f ./cabal-config diff --git a/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out b/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/overwrites_with_f.out +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/overwrites_with_f.sh +++ /dev/null @@ -1,9 +0,0 @@ -. ../common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init \ - || die "Couldn't create config file" -cabal --config-file=./cabal-config user-config -f init \ - || die "Couldn't create config file" -test -e ./cabal-config || die "Config file doesn't exist" -rm -f ./cabal-config diff --git a/tests/IntegrationTests/user-config/should_run/runs_without_error.out b/tests/IntegrationTests/user-config/should_run/runs_without_error.out deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/runs_without_error.out +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/runs_without_error.sh +++ /dev/null @@ -1,7 +0,0 @@ -. ../common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init \ - || die "Couldn't create config file" -test -e ./cabal-config || die "Config file doesn't exist" -rm -f ./cabal-config diff --git a/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out b/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.out +++ /dev/null @@ -1,1 +0,0 @@ -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 deleted file mode 100644 --- a/tests/IntegrationTests/user-config/should_run/uses_CABAL_CONFIG.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ../common.sh - -export CABAL_CONFIG=./my-config -cabal user-config init || die "Couldn't create config file" -test -e ./my-config || die "Config file doesn't exist" diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2.hs @@ -0,0 +1,1719 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +-- For the handy instance IsString PackageIdentifier +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module IntegrationTests2 where + +import Distribution.Client.DistDirLayout +import Distribution.Client.ProjectConfig +import Distribution.Client.Config (defaultCabalDir) +import Distribution.Client.TargetSelector hiding (DirActions(..)) +import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectOrchestration + ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents ) +import Distribution.Client.Types + ( PackageLocation(..), UnresolvedSourcePackage ) +import Distribution.Client.Targets + ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Solver.Types.SourcePackage as SP +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(ConstraintSourceUnknown) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(PackagePropertySource) ) + +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdHaddock as CmdHaddock + +import Distribution.Package +import Distribution.PackageDescription +import qualified Distribution.Types.GenericPackageDescription as GPG +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) +import Distribution.Simple.Compiler +import Distribution.System +import Distribution.Version +import Distribution.ModuleName (ModuleName) +import Distribution.Verbosity +import Distribution.Text + +import Data.Monoid +import Data.List (sort) +import Data.String (IsString(..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import Control.Exception hiding (assert) +import System.FilePath +import System.Directory + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options +import Data.Tagged (Tagged(..)) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) + + +main :: IO () +main = + defaultMainWithIngredients + (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) + (withProjectConfig $ \config -> + testGroup "Integration tests (internal)" + (tests config)) + + +tests :: ProjectConfig -> [TestTree] +tests config = + --TODO: tests for: + -- * normal success + -- * dry-run tests with changes + [ testGroup "Discovery and planning" $ + [ testCase "find root" testFindProjectRoot + , testCase "find root fail" testExceptionFindProjectRoot + , testCase "no package" (testExceptionInFindingPackage config) + , testCase "no package2" (testExceptionInFindingPackage2 config) + , testCase "proj conf1" (testExceptionInProjectConfig config) + ] + , testGroup "Target selectors" $ + [ testCaseSteps "valid" testTargetSelectors + , testCase "bad syntax" testTargetSelectorBadSyntax + , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous + , testCase "no current pkg" testTargetSelectorNoCurrentPackage + , testCase "no targets" testTargetSelectorNoTargets + , testCase "project empty" testTargetSelectorProjectEmpty + , testCase "problems (common)" (testTargetProblemsCommon config) + , testCaseSteps "problems (build)" (testTargetProblemsBuild config) + , testCaseSteps "problems (repl)" (testTargetProblemsRepl config) + , testCaseSteps "problems (run)" (testTargetProblemsRun config) + , testCaseSteps "problems (test)" (testTargetProblemsTest config) + , testCaseSteps "problems (bench)" (testTargetProblemsBench config) + , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config) + ] + , testGroup "Exceptions during building (local inplace)" $ + [ testCase "configure" (testExceptionInConfigureStep config) + , testCase "build" (testExceptionInBuildStep config) +-- , testCase "register" testExceptionInRegisterStep + ] + --TODO: need to repeat for packages for the store + --TODO: need to check we can build sub-libs, foreign libs and exes + -- components for non-local packages / packages in the store. + + , testGroup "Successful builds" $ + [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) + , testCase "keep-going" (testBuildKeepGoing config) + ] + + , testGroup "Regression tests" $ + [ testCase "issue #3324" (testRegressionIssue3324 config) + ] + ] + + +testFindProjectRoot :: Assertion +testFindProjectRoot = do + Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir) + (Just testfile) + file @?= testfile + where + testdir = basedir "exception" "no-pkg2" + testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN" + + +testExceptionFindProjectRoot :: Assertion +testExceptionFindProjectRoot = do + Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing + cwd <- getCurrentDirectory + dir @?= cwd testdir + where + testdir = basedir "exception" "no-pkg2" + + +testTargetSelectors :: (String -> IO ()) -> Assertion +testTargetSelectors reportSubCase = do + (_, _, _, localPackages, _) <- configureProject testdir config + let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + localPackages + + reportSubCase "cwd" + do Right ts <- readTargetSelectors' [] + ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing] + + reportSubCase "all" + do Right ts <- readTargetSelectors' + ["all", ":all"] + ts @?= replicate 2 (TargetAllPackages Nothing) + + reportSubCase "filter" + do Right ts <- readTargetSelectors' + [ "libs", ":cwd:libs" + , "flibs", ":cwd:flibs" + , "exes", ":cwd:exes" + , "tests", ":cwd:tests" + , "benchmarks", ":cwd:benchmarks"] + zipWithM_ (@?=) ts + [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind) + | kind <- concatMap (replicate 2) [LibKind .. ] + ] + + reportSubCase "all:filter" + do Right ts <- readTargetSelectors' + [ "all:libs", ":all:libs" + , "all:flibs", ":all:flibs" + , "all:exes", ":all:exes" + , "all:tests", ":all:tests" + , "all:benchmarks", ":all:benchmarks"] + zipWithM_ (@?=) ts + [ TargetAllPackages (Just kind) + | kind <- concatMap (replicate 2) [LibKind .. ] + ] + + reportSubCase "pkg" + do Right ts <- readTargetSelectors' + [ ":pkg:p", ".", "./", "p.cabal" + , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] + ts @?= replicate 4 (mkTargetPackage "p-0.1") + ++ replicate 5 (mkTargetPackage "q-0.1") + + reportSubCase "pkg:filter" + do Right ts <- readTargetSelectors' + [ "p:libs", ".:libs", ":pkg:p:libs" + , "p:flibs", ".:flibs", ":pkg:p:flibs" + , "p:exes", ".:exes", ":pkg:p:exes" + , "p:tests", ".:tests", ":pkg:p:tests" + , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks" + , "q:libs", "q/:libs", ":pkg:q:libs" + , "q:flibs", "q/:flibs", ":pkg:q:flibs" + , "q:exes", "q/:exes", ":pkg:q:exes" + , "q:tests", "q/:tests", ":pkg:q:tests" + , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] + zipWithM_ (@?=) ts $ + [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind) + | kind <- concatMap (replicate 3) [LibKind .. ] + ] ++ + [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind) + | kind <- concatMap (replicate 3) [LibKind .. ] + ] + + reportSubCase "component" + do Right ts <- readTargetSelectors' + [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" + , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] + ts @?= replicate 4 (TargetComponent "p-0.1" CLibName WholeComponent) + ++ replicate 3 (TargetComponent "q-0.1" CLibName WholeComponent) + + reportSubCase "module" + do Right ts <- readTargetSelectors' + [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" + , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" + , "pexe:PMain" -- p:P or q:QQ would be ambiguous here + , "qexe:QMain" -- package p vs component p + ] + ts @?= replicate 4 (TargetComponent "p-0.1" CLibName (ModuleTarget "P")) + ++ replicate 4 (TargetComponent "q-0.1" CLibName (ModuleTarget "QQ")) + ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") + , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") + ] + + reportSubCase "file" + do Right ts <- readTargetSelectors' + [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", + ":pkg:p:lib:p:file:P.y" + , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", + ":pkg:q:lib:q:file:QQ.y" + ] + ts @?= replicate 5 (TargetComponent "p-0.1" CLibName (FileTarget "P")) + ++ replicate 5 (TargetComponent "q-0.1" CLibName (FileTarget "QQ")) + -- Note there's a bit of an inconsistency here: for the single-part + -- syntax the target has to point to a file that exists, whereas for + -- all the other forms we don't require that. + + cleanProject testdir + where + testdir = "targets/simple" + config = mempty + + +testTargetSelectorBadSyntax :: Assertion +testTargetSelectorBadSyntax = do + (_, _, _, localPackages, _) <- configureProject testdir config + let targets = [ "foo bar", " foo" + , "foo:", "foo::bar" + , "foo: ", "foo: :bar" + , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] + Left errs <- readTargetSelectors localPackages targets + zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) + cleanProject testdir + where + testdir = "targets/empty" + config = mempty + + +testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion +testTargetSelectorAmbiguous reportSubCase = do + + -- 'all' is ambiguous with packages and cwd components + reportSubCase "ambiguous: all vs pkg" + assertAmbiguous "all" + [mkTargetPackage "all", mkTargetAllPackages] + [mkpkg "all" []] + + reportSubCase "ambiguous: all vs cwd component" + assertAmbiguous "all" + [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages] + [mkpkg "other" [mkexe "all"]] + + -- but 'all' is not ambiguous with non-cwd components, modules or files + reportSubCase "unambiguous: all vs non-cwd comp, mod, file" + assertUnambiguous "All" + mkTargetAllPackages + [ mkpkgAt "foo" [mkexe "All"] "foo" + , mkpkg "bar" [ mkexe "bar" `withModules` ["All"] + , mkexe "baz" `withCFiles` ["All"] ] + ] + + -- filters 'libs', 'exes' etc are ambiguous with packages and + -- local components + reportSubCase "ambiguous: cwd-pkg filter vs pkg" + assertAmbiguous "libs" + [ mkTargetPackage "libs" + , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ] + [mkpkg "libs" []] + + reportSubCase "ambiguous: filter vs cwd component" + assertAmbiguous "exes" + [ mkTargetComponent "other" (CExeName "exes") + , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ] + [mkpkg "other" [mkexe "exes"]] + + -- but filters are not ambiguous with non-cwd components, modules or files + reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" + assertUnambiguous "Libs" + (TargetPackage TargetImplicitCwd "bar" (Just LibKind)) + [ mkpkgAt "foo" [mkexe "Libs"] "foo" + , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] + , mkexe "baz" `withCFiles` ["Libs"] ] + ] + + -- local components shadow packages and other components + reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp" + assertUnambiguous "foo" + (mkTargetComponent "other" (CExeName "foo")) + [ mkpkg "other" [mkexe "foo"] + , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo + , mkpkg "foo" [] ] -- shadows package foo + + -- local components shadow modules and files + reportSubCase "unambiguous: cwd comp vs module, file" + assertUnambiguous "Foo" + (mkTargetComponent "bar" (CExeName "Foo")) + [ mkpkg "bar" [mkexe "Foo"] + , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] + , mkexe "other2" `withCFiles` ["Foo"] ] + ] + + -- packages shadow non-local components + reportSubCase "unambiguous: pkg vs non-cwd comp" + assertUnambiguous "foo" + (mkTargetPackage "foo") + [ mkpkg "foo" [] + , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo + ] + + -- packages shadow modules and files + reportSubCase "unambiguous: pkg vs module, file" + assertUnambiguous "Foo" + (mkTargetPackage "Foo") + [ mkpkgAt "Foo" [] "foo" + , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] + , mkexe "other2" `withCFiles` ["Foo"] ] + ] + + -- non-exact case packages and components are ambiguous + reportSubCase "ambiguous: non-exact-case pkg names" + assertAmbiguous "Foo" + [ mkTargetPackage "foo", mkTargetPackage "FOO" ] + [ mkpkg "foo" [], mkpkg "FOO" [] ] + reportSubCase "ambiguous: non-exact-case comp names" + assertAmbiguous "Foo" + [ mkTargetComponent "bar" (CExeName "foo") + , mkTargetComponent "bar" (CExeName "FOO") ] + [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ] + + -- exact-case Module or File over non-exact case package or component + reportSubCase "unambiguous: module vs non-exact-case pkg, comp" + assertUnambiguous "Baz" + (mkTargetModule "other" (CExeName "other") "Baz") + [ mkpkg "baz" [mkexe "BAZ"] + , mkpkg "other" [ mkexe "other" `withModules` ["Baz"] ] + ] + reportSubCase "unambiguous: file vs non-exact-case pkg, comp" + assertUnambiguous "Baz" + (mkTargetFile "other" (CExeName "other") "Baz") + [ mkpkg "baz" [mkexe "BAZ"] + , mkpkg "other" [ mkexe "other" `withCFiles` ["Baz"] ] + ] + where + assertAmbiguous :: String + -> [TargetSelector PackageId] + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertAmbiguous str tss pkgs = do + res <- readTargetSelectorsWith fakeDirActions pkgs [str] + case res of + Left [TargetSelectorAmbiguous _ tss'] -> + sort (map snd tss') @?= sort tss + _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], " + ++ "got " ++ show res + + assertUnambiguous :: String + -> TargetSelector PackageId + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertUnambiguous str ts pkgs = do + res <- readTargetSelectorsWith fakeDirActions pkgs [str] + case res of + Right [ts'] -> ts' @?= ts + _ -> assertFailure $ "expected Right [Target...], " + ++ "got " ++ show res + + fakeDirActions = TS.DirActions { + TS.doesFileExist = \_p -> return True, + TS.doesDirectoryExist = \_p -> return True, + TS.canonicalizePath = \p -> return ("/" p), -- FilePath.Unix. ? + TS.getCurrentDirectory = return "/" + } + + mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a) + mkpkg pkgidstr exes = mkpkgAt pkgidstr exes "" + + mkpkgAt :: String -> [Executable] -> FilePath + -> SourcePackage (PackageLocation a) + mkpkgAt pkgidstr exes loc = + SourcePackage { + packageInfoId = pkgid, + packageSource = LocalUnpackedPackage loc, + packageDescrOverride = Nothing, + SP.packageDescription = GenericPackageDescription { + GPG.packageDescription = emptyPackageDescription { package = pkgid }, + genPackageFlags = [], + condLibrary = Nothing, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [ ( exeName exe, CondNode exe [] [] ) + | exe <- exes ], + condTestSuites = [], + condBenchmarks = [] + } + } + where + Just pkgid = simpleParse pkgidstr + + mkexe :: String -> Executable + mkexe name = mempty { exeName = fromString name } + + withModules :: Executable -> [String] -> Executable + withModules exe mods = + exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } } + + withCFiles :: Executable -> [FilePath] -> Executable + withCFiles exe files = + exe { buildInfo = (buildInfo exe) { cSources = files } } + + +mkTargetPackage :: PackageId -> TargetSelector PackageId +mkTargetPackage pkgid = + TargetPackage TargetExplicitNamed pkgid Nothing + +mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId +mkTargetComponent pkgid cname = + TargetComponent pkgid cname WholeComponent + +mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId +mkTargetModule pkgid cname mname = + TargetComponent pkgid cname (ModuleTarget mname) + +mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId +mkTargetFile pkgid cname fname = + TargetComponent pkgid cname (FileTarget fname) + +mkTargetAllPackages :: TargetSelector PackageId +mkTargetAllPackages = TargetAllPackages Nothing + +instance IsString PackageIdentifier where + fromString pkgidstr = pkgid + where Just pkgid = simpleParse pkgidstr + + +testTargetSelectorNoCurrentPackage :: Assertion +testTargetSelectorNoCurrentPackage = do + (_, _, _, localPackages, _) <- configureProject testdir config + let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + localPackages + targets = [ "libs", ":cwd:libs" + , "flibs", ":cwd:flibs" + , "exes", ":cwd:exes" + , "tests", ":cwd:tests" + , "benchmarks", ":cwd:benchmarks"] + Left errs <- readTargetSelectors' targets + zipWithM_ (@?=) errs + [ TargetSelectorNoCurrentPackage ts + | target <- targets + , let Just ts = parseTargetString target + ] + cleanProject testdir + where + testdir = "targets/complex" + config = mempty + + +testTargetSelectorNoTargets :: Assertion +testTargetSelectorNoTargets = do + (_, _, _, localPackages, _) <- configureProject testdir config + Left errs <- readTargetSelectors localPackages [] + errs @?= [TargetSelectorNoTargetsInCwd] + cleanProject testdir + where + testdir = "targets/complex" + config = mempty + + +testTargetSelectorProjectEmpty :: Assertion +testTargetSelectorProjectEmpty = do + (_, _, _, localPackages, _) <- configureProject testdir config + Left errs <- readTargetSelectors localPackages [] + errs @?= [TargetSelectorNoTargetsInProject] + cleanProject testdir + where + testdir = "targets/empty" + config = mempty + + +testTargetProblemsCommon :: ProjectConfig -> Assertion +testTargetProblemsCommon config0 = do + (_,elaboratedPlan,_) <- planProject testdir config + + let pkgIdMap :: Map.Map PackageName PackageId + pkgIdMap = Map.fromList + [ (packageName p, packageId p) + | p <- InstallPlan.toList elaboratedPlan ] + + cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem + , TargetSelector PackageId + )] + cases = + [ -- Cannot resolve packages outside of the project + ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchPackage "foobar" + , mkTargetPackage "foobar" ) + + -- We cannot currently build components like testsuites or + -- benchmarks from packages that are not local to the project + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetComponentNotProjectLocal + (pkgIdMap Map.! "filepath") (CTestName "filepath-tests") + WholeComponent + , mkTargetComponent (pkgIdMap Map.! "filepath") + (CTestName "filepath-tests") ) + + -- Components can be explicitly @buildable: False@ + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent + , mkTargetComponent "q-0.1" (CExeName "buildable-false") ) + + -- Testsuites and benchmarks can be disabled by the solver if it + -- cannot satisfy deps + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent + , mkTargetComponent "q-0.1" (CTestName "solver-disabled") ) + + -- Testsuites and benchmarks can be disabled explicitly by the + -- user via config + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetOptionalStanzaDisabledByUser + "q-0.1" (CBenchName "user-disabled") WholeComponent + , mkTargetComponent "q-0.1" (CBenchName "user-disabled") ) + + -- An unknown package. The target selector resolution should only + -- produce known packages, so this should not happen with the + -- output from 'readTargetSelectors'. + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchPackage "foobar" + , mkTargetPackage "foobar" ) + + -- An unknown component of a known package. The target selector + -- resolution should only produce known packages, so this should + -- not happen with the output from 'readTargetSelectors'. + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such") + , mkTargetComponent "q-0.1" (CExeName "no-such") ) + ] + assertTargetProblems + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + cases + where + testdir = "targets/complex" + config = config0 { + projectConfigLocalPackages = (projectConfigLocalPackages config0) { + packageConfigBenchmarks = toFlag False + } + , projectConfigShared = (projectConfigShared config0) { + projectConfigConstraints = + [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource + , ConstraintSourceUnknown )] + } + } + + +testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsBuild config reportSubCase = do + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ ( CmdBuild.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "all-disabled" + assertProjectTargetProblems + "targets/all-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigBenchmarks = toFlag False + } + } + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ ( flip CmdBuild.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CExeName "buildable-false") + TargetNotBuildable True + , AvailableTarget "p-0.1" CLibName + TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "enabled component kinds" + -- When we explicitly enable all the component kinds then selecting the + -- whole package selects those component kinds too + do (_,elaboratedPlan,_) <- planProject "targets/variety" config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag True, + packageConfigBenchmarks = toFlag True + } + } + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "disabled component kinds" + -- When we explicitly disable all the component kinds then selecting the + -- whole package only selects the library, foreign lib and exes + do (_,elaboratedPlan,_) <- planProject "targets/variety" config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag False, + packageConfigBenchmarks = toFlag False + } + } + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "requested component kinds" + -- When we selecting the package with an explicit filter then we get those + -- components even though we did not explicitly enable tests/benchmarks + do (_,elaboratedPlan,_) <- planProject "targets/variety" config + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + ] + + +testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsRepl config reportSubCase = do + + reportSubCase "multiple-libs" + assertProjectTargetProblems + "targets/multiple-libs" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" CLibName + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "q-0.1" CLibName + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetAllPackages ) + ] + + reportSubCase "multiple-exes" + assertProjectTargetProblems + "targets/multiple-exes" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CExeName "p2") + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "p-0.1" (CExeName "p1") + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "multiple-tests" + assertProjectTargetProblems + "targets/multiple-tests" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CTestName "p2") + (TargetBuildable () TargetNotRequestedByDefault) True + , AvailableTarget "p-0.1" (CTestName "p1") + (TargetBuildable () TargetNotRequestedByDefault) True + ] + , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ) + ] + + reportSubCase "multiple targets" + do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ mkTargetComponent "p-0.1" (CExeName "p1") + , mkTargetComponent "p-0.1" (CExeName "p2") + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + , ("p-0.1-inplace-p2", CExeName "p2") + ] + + reportSubCase "libs-disabled" + assertProjectTargetProblems + "targets/libs-disabled" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" CLibName TargetNotBuildable True ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "exes-disabled" + assertProjectTargetProblems + "targets/exes-disabled" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "test-only" + assertProjectTargetProblems + "targets/test-only" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "pexe") + (TargetBuildable () TargetNotRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( CmdRepl.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "requested component kinds" + do (_,elaboratedPlan,_) <- planProject "targets/variety" config + -- by default we only get the lib + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ] + [ ("p-0.1-inplace", CLibName) ] + -- When we select the package with an explicit filter then we get those + -- components even though we did not explicitly enable tests/benchmarks + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ] + [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] + + +testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsRun config reportSubCase = do + + reportSubCase "multiple-exes" + assertProjectTargetProblems + "targets/multiple-exes" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( flip CmdRun.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CExeName "p2") + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "p-0.1" (CExeName "p1") + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "multiple targets" + do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config + assertProjectDistinctTargets + elaboratedPlan + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ mkTargetComponent "p-0.1" (CExeName "p1") + , mkTargetComponent "p-0.1" (CExeName "p2") + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + , ("p-0.1-inplace-p2", CExeName "p2") + ] + + reportSubCase "exes-disabled" + assertProjectTargetProblems + "targets/exes-disabled" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( flip CmdRun.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "test-only" + assertProjectTargetProblems + "targets/test-only" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "variety" + assertProjectTargetProblems + "targets/variety" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon $ + [ ( const (CmdRun.TargetProblemComponentNotExe "p-0.1" cname) + , mkTargetComponent "p-0.1" cname ) + | cname <- [ CLibName, CFLibName "libp", + CTestName "a-testsuite", CBenchName "a-benchmark" ] + ] ++ + [ ( const (CmdRun.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdRun.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsTest config reportSubCase = do + + reportSubCase "disabled by config" + assertProjectTargetProblems + "targets/tests-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag False + } + } + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledByUser True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "disabled by solver & buildable false" + assertProjectTargetProblems + "targets/tests-disabled" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "user-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + ] + , mkTargetPackage "p-0.1" ) + + , ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "q-0.1" (CTestName "buildable-false") + TargetNotBuildable True + ] + , mkTargetPackage "q-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( CmdTest.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "no tests" + assertProjectTargetProblems + "targets/simple" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( CmdTest.TargetProblemNoTests, mkTargetPackage "p-0.1" ) + , ( CmdTest.TargetProblemNoTests, mkTargetPackage "q-0.1" ) + ] + + reportSubCase "not a test" + assertProjectTargetProblems + "targets/variety" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon $ + [ ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" CLibName) + , mkTargetComponent "p-0.1" CLibName ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CExeName "an-exe")) + , mkTargetComponent "p-0.1" (CExeName "an-exe") ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CFLibName "libp")) + , mkTargetComponent "p-0.1" (CFLibName "libp") ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CBenchName "a-benchmark")) + , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") ) + ] ++ + [ ( const (CmdTest.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdTest.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsBench config reportSubCase = do + + reportSubCase "disabled by config" + assertProjectTargetProblems + "targets/benchmarks-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigBenchmarks = toFlag False + } + } + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CBenchName "solver-disabled") + TargetDisabledByUser True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "disabled by solver & buildable false" + assertProjectTargetProblems + "targets/benchmarks-disabled" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CBenchName "solver-disabled") + TargetDisabledBySolver True + ] + , mkTargetPackage "p-0.1" ) + + , ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "q-0.1" (CBenchName "buildable-false") + TargetNotBuildable True + ] + , mkTargetPackage "q-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( CmdBench.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "no benchmarks" + assertProjectTargetProblems + "targets/simple" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "p-0.1" ) + , ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "q-0.1" ) + ] + + reportSubCase "not a benchmark" + assertProjectTargetProblems + "targets/variety" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon $ + [ ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" CLibName) + , mkTargetComponent "p-0.1" CLibName ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CExeName "an-exe")) + , mkTargetComponent "p-0.1" (CExeName "an-exe") ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CFLibName "libp")) + , mkTargetComponent "p-0.1" (CFLibName "libp") ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CTestName "a-testsuite")) + , mkTargetComponent "p-0.1" (CTestName "a-testsuite") ) + ] ++ + [ ( const (CmdBench.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdBench.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsHaddock config reportSubCase = do + + reportSubCase "all-disabled" + assertProjectTargetProblems + "targets/all-disabled" + config + (let haddockFlags = mkHaddockFlags False True True False + in CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ ( flip CmdHaddock.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CExeName "buildable-false") + TargetNotBuildable True + , AvailableTarget "p-0.1" CLibName + TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + (let haddockFlags = mkHaddockFlags False False False False + in CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ ( CmdHaddock.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "enabled component kinds" + -- When we explicitly enable all the component kinds then selecting the + -- whole package selects those component kinds too + (_,elaboratedPlan,_) <- planProject "targets/variety" config + let haddockFlags = mkHaddockFlags True True True True + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "disabled component kinds" + -- When we explicitly disable all the component kinds then selecting the + -- whole package only selects the library + let haddockFlags = mkHaddockFlags False False False False + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) ] + + reportSubCase "requested component kinds" + -- When we selecting the package with an explicit filter then it does not + -- matter if the config was to disable all the component kinds + let haddockFlags = mkHaddockFlags False False False False + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + where + mkHaddockFlags flib exe test bench = + defaultHaddockFlags { + haddockForeignLibs = toFlag flib, + haddockExecutables = toFlag exe, + haddockTestSuites = toFlag test, + haddockBenchmarks = toFlag bench + } + +assertProjectDistinctTargets + :: forall err. (Eq err, Show err) => + ElaboratedInstallPlan + -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (TargetProblemCommon -> err) + -> [TargetSelector PackageId] + -> [(UnitId, ComponentName)] + -> Assertion +assertProjectDistinctTargets elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem + targetSelectors + expectedTargets + | Right targets <- results + = distinctTargetComponents targets @?= Set.fromList expectedTargets + + | otherwise + = assertFailure $ "assertProjectDistinctTargets: expected " + ++ "(Right targets) but got " ++ show results + where + results = resolveTargets + selectPackageTargets + selectComponentTarget + liftProblem + elaboratedPlan + targetSelectors + + +assertProjectTargetProblems + :: forall err. (Eq err, Show err) => + FilePath -> ProjectConfig + -> (forall k. TargetSelector PackageId + -> [AvailableTarget k] + -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k + -> Either err k ) + -> (TargetProblemCommon -> err) + -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> Assertion +assertProjectTargetProblems testdir config + selectPackageTargets + selectComponentTarget + liftProblem + cases = do + (_,elaboratedPlan,_) <- planProject testdir config + assertTargetProblems + elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem + cases + + +assertTargetProblems + :: forall err. (Eq err, Show err) => + ElaboratedInstallPlan + -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (TargetProblemCommon -> err) + -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> Assertion +assertTargetProblems elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem = + mapM_ (uncurry assertTargetProblem) + where + assertTargetProblem expected targetSelector = + let res = resolveTargets selectPackageTargets selectComponentTarget + liftProblem elaboratedPlan [targetSelector] in + case res of + Left [problem] -> + problem @?= expected targetSelector + + unexpected -> + assertFailure $ "expected resolveTargets result: (Left [problem]) " + ++ "but got: " ++ show unexpected + + +testExceptionInFindingPackage :: ProjectConfig -> Assertion +testExceptionInFindingPackage config = do + BadPackageLocations _ locs <- expectException "BadPackageLocations" $ + void $ planProject testdir config + case locs of + [BadLocGlobEmptyMatch "./*.cabal"] -> return () + _ -> assertFailure "expected BadLocGlobEmptyMatch" + cleanProject testdir + where + testdir = "exception/no-pkg" + + +testExceptionInFindingPackage2 :: ProjectConfig -> Assertion +testExceptionInFindingPackage2 config = do + BadPackageLocations _ locs <- expectException "BadPackageLocations" $ + void $ planProject testdir config + case locs of + [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () + _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs + cleanProject testdir + where + testdir = "exception/no-pkg2" + + +testExceptionInProjectConfig :: ProjectConfig -> Assertion +testExceptionInProjectConfig config = do + BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $ + void $ planProject testdir config + case ps of + [(pn,"ghc")] | "foo" == pn -> return () + _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got " + ++ show ps + cleanProject testdir + where + testdir = "exception/bad-config" + + +testExceptionInConfigureStep :: ProjectConfig -> Assertion +testExceptionInConfigureStep config = do + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 + case buildFailureReason failure of + ConfigureFailed _ -> return () + _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure + cleanProject testdir + where + testdir = "exception/configure" + pkgidA1 = PackageIdentifier "a" (mkVersion [1]) + + +testExceptionInBuildStep :: ProjectConfig -> Assertion +testExceptionInBuildStep config = do + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 + expectBuildFailed failure + where + testdir = "exception/build" + pkgidA1 = PackageIdentifier "a" (mkVersion [1]) + +testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion +testSetupScriptStyles config reportSubCase = do + + reportSubCase (show SetupCustomExplicitDeps) + + plan0@(_,_,sharedConfig) <- planProject testdir1 config + + let isOSX (Platform _ OSX) = True + isOSX _ = False + -- Skip the Custom tests when the shipped Cabal library is buggy + unless (isOSX (pkgConfigPlatform sharedConfig) + && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do + + (plan1, res1) <- executePlan plan0 + (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA + elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps + hasDefaultSetupDeps pkg1 @?= Just False + marker1 <- readFile (basedir testdir1 "marker") + marker1 @?= "ok" + removeFile (basedir testdir1 "marker") + + reportSubCase (show SetupCustomImplicitDeps) + (plan2, res2) <- executePlan =<< planProject testdir2 config + (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA + elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps + hasDefaultSetupDeps pkg2 @?= Just True + marker2 <- readFile (basedir testdir2 "marker") + marker2 @?= "ok" + removeFile (basedir testdir2 "marker") + + reportSubCase (show SetupNonCustomInternalLib) + (plan3, res3) <- executePlan =<< planProject testdir3 config + (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA + elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib +{- + --TODO: the SetupNonCustomExternalLib case is hard to test since it + -- requires a version of Cabal that's later than the one we're testing + -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0 + -- and a corresponding Cabal package that we can use to try and build a + -- default Setup.hs. + reportSubCase (show SetupNonCustomExternalLib) + (plan4, res4) <- executePlan =<< planProject testdir4 config + (pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA + pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib +-} + where + testdir1 = "build/setup-custom1" + testdir2 = "build/setup-custom2" + testdir3 = "build/setup-simple" + pkgidA = PackageIdentifier "a" (mkVersion [0,1]) + -- The solver fills in default setup deps explicitly, but marks them as such + hasDefaultSetupDeps = fmap defaultSetupDepends + . setupBuildInfo . elabPkgDescription + +-- | Test the behaviour with and without @--keep-going@ +-- +testBuildKeepGoing :: ProjectConfig -> Assertion +testBuildKeepGoing config = do + -- P is expected to fail, Q does not depend on P but without + -- parallel build and without keep-going then we don't build Q yet. + (plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False) + (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1" + expectBuildFailed failure1 + _ <- expectPackageConfigured plan1 res1 "q-0.1" + + -- With keep-going then we should go on to sucessfully build Q + (plan2, res2) <- executePlan + =<< planProject testdir (config <> keepGoing True) + (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1" + expectBuildFailed failure2 + _ <- expectPackageInstalled plan2 res2 "q-0.1" + return () + where + testdir = "build/keep-going" + keepGoing kg = + mempty { + projectConfigBuildOnly = mempty { + projectConfigKeepGoing = toFlag kg + } + } + +-- | See +-- +testRegressionIssue3324 :: ProjectConfig -> Assertion +testRegressionIssue3324 config = do + -- expected failure first time due to missing dep + (plan1, res1) <- executePlan =<< planProject testdir config + (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1" + expectBuildFailed failure + + -- add the missing dep, now it should work + let qcabal = basedir testdir "q" "q.cabal" + withFileFinallyRestore qcabal $ do + appendFile qcabal (" build-depends: p\n") + (plan2, res2) <- executePlan =<< planProject testdir config + _ <- expectPackageInstalled plan2 res2 "p-0.1" + _ <- expectPackageInstalled plan2 res2 "q-0.1" + return () + where + testdir = "regression/3324" + + +--------------------------------- +-- Test utils to plan and build +-- + +basedir :: FilePath +basedir = "tests" "IntegrationTests2" + +dirActions :: FilePath -> TS.DirActions IO +dirActions testdir = + defaultDirActions { + TS.doesFileExist = \p -> + TS.doesFileExist defaultDirActions (virtcwd p), + + TS.doesDirectoryExist = \p -> + TS.doesDirectoryExist defaultDirActions (virtcwd p), + + TS.canonicalizePath = \p -> + TS.canonicalizePath defaultDirActions (virtcwd p), + + TS.getCurrentDirectory = + TS.canonicalizePath defaultDirActions virtcwd + } + where + virtcwd = basedir testdir + +type ProjDetails = (DistDirLayout, + CabalDirLayout, + ProjectConfig, + [UnresolvedSourcePackage], + BuildTimeSettings) + +configureProject :: FilePath -> ProjectConfig -> IO ProjDetails +configureProject testdir cliConfig = do + cabalDir <- defaultCabalDir + let cabalDirLayout = defaultCabalDirLayout cabalDir + + projectRootDir <- canonicalizePath (basedir testdir) + isexplict <- doesFileExist (projectRootDir "cabal.project") + let projectRoot + | isexplict = ProjectRootExplicit projectRootDir + (projectRootDir "cabal.project") + | otherwise = ProjectRootImplicit projectRootDir + distDirLayout = defaultDistDirLayout projectRoot Nothing + + -- Clear state between test runs. The state remains if the previous run + -- ended in an exception (as we leave the files to help with debugging). + cleanProject testdir + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + distDirLayout + cliConfig + + let buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return (distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings) + +type PlanDetails = (ProjDetails, + ElaboratedInstallPlan, + ElaboratedSharedConfig) + +planProject :: FilePath -> ProjectConfig -> IO PlanDetails +planProject testdir cliConfig = do + + projDetails@ + (distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + _buildSettings) <- configureProject testdir cliConfig + + (elaboratedPlan, _, elaboratedShared) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + return (projDetails, + elaboratedPlan, + elaboratedShared) + +executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes) +executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings), + elaboratedPlan, + elaboratedShared) = do + + let targets :: Map.Map UnitId [ComponentTarget] + targets = + Map.fromList + [ (unitid, [ComponentTarget cname WholeComponent]) + | ts <- Map.elems (availableTargets elaboratedPlan) + , AvailableTarget { + availableTargetStatus = TargetBuildable (unitid, cname) _ + } <- ts + ] + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild targets + elaboratedPlan + + pkgsBuildStatus <- + rebuildTargetsDryRun distDirLayout elaboratedShared + elaboratedPlan' + + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + + buildOutcomes <- + rebuildTargets verbosity + distDirLayout + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlan'' + elaboratedShared + pkgsBuildStatus + -- Avoid trying to use act-as-setup mode: + buildSettings { buildSettingNumJobs = 1 } + + return (elaboratedPlan'', buildOutcomes) + +cleanProject :: FilePath -> IO () +cleanProject testdir = do + alreadyExists <- doesDirectoryExist distDir + when alreadyExists $ removeDirectoryRecursive distDir + where + projectRoot = ProjectRootImplicit (basedir testdir) + distDirLayout = defaultDistDirLayout projectRoot Nothing + distDir = distDirectory distDirLayout + + +verbosity :: Verbosity +verbosity = minBound --normal --verbose --maxBound --minBound + + + +------------------------------------------- +-- Tasty integration to adjust the config +-- + +withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree +withProjectConfig testtree = + askOption $ \ghcPath -> + testtree (mkProjectConfig ghcPath) + +mkProjectConfig :: GhcPath -> ProjectConfig +mkProjectConfig (GhcPath ghcPath) = + mempty { + projectConfigShared = mempty { + projectConfigHcPath = maybeToFlag ghcPath + }, + projectConfigBuildOnly = mempty { + projectConfigNumJobs = toFlag (Just 1) + } + } + where + maybeToFlag = maybe mempty toFlag + + +data GhcPath = GhcPath (Maybe FilePath) + deriving Typeable + +instance IsOption GhcPath where + defaultValue = GhcPath Nothing + optionName = Tagged "with-ghc" + optionHelp = Tagged "The ghc compiler to use" + parseValue = Just . GhcPath . Just + +projectConfigOptionDescriptions :: [OptionDescription] +projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)] + + +--------------------------------------- +-- HUint style utils for this context +-- + +expectException :: Exception e => String -> IO a -> IO e +expectException expected action = do + res <- try action + case res of + Left e -> return e + Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected + +expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO InstalledPackageInfo +expectPackagePreExisting plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.PreExisting pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult + +expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO ElaboratedConfiguredPackage +expectPackageConfigured plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult + +expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildResult) +expectPackageInstalled plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Just (Right result)) + -> return (pkg, result) + (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult + +expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildFailure) +expectPackageFailed plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Just (Left failure)) + -> return (pkg, failure) + (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult + +unexpectedBuildResult :: String -> ElaboratedPlanPackage + -> Maybe (Either BuildFailure BuildResult) -> IO a +unexpectedBuildResult expected planpkg buildResult = + throwIO $ HUnitFailure $ + "expected to find " ++ display (packageId planpkg) ++ " in the " + ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." + where + actual = case (buildResult, planpkg) of + (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" + (Nothing, InstallPlan.Configured{}) -> "Configured" + (Just (Right _), InstallPlan.Configured{}) -> "Installed" + (Just (Left _), InstallPlan.Configured{}) -> "Failed" + _ -> "Impossible!" + +expectPlanPackage :: ElaboratedInstallPlan -> PackageId + -> IO ElaboratedPlanPackage +expectPlanPackage plan pkgid = + case [ pkg + | pkg <- InstallPlan.toList plan + , packageId pkg == pkgid ] of + [pkg] -> return pkg + [] -> throwIO $ HUnitFailure $ + "expected to find " ++ display pkgid + ++ " in the install plan but it's not there" + _ -> throwIO $ HUnitFailure $ + "expected to find only one instance of " ++ display pkgid + ++ " in the install plan but there's several" + +expectBuildFailed :: BuildFailure -> IO () +expectBuildFailed (BuildFailure _ (BuildFailed _)) = return () +expectBuildFailed (BuildFailure _ reason) = + assertFailure $ "expected BuildFailed, got " ++ show reason + +--------------------------------------- +-- Other utils +-- + +-- | Allow altering a file during a test, but then restore it afterwards +-- +withFileFinallyRestore :: FilePath -> IO a -> IO a +withFileFinallyRestore file action = do + copyFile file backup + action `finally` renameFile backup file + where + backup = file <.> "backup" diff --git a/tests/IntegrationTests2/build/keep-going/cabal.project b/tests/IntegrationTests2/build/keep-going/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/keep-going/cabal.project @@ -0,0 +1,1 @@ +packages: p q diff --git a/tests/IntegrationTests2/build/keep-going/p/P.hs b/tests/IntegrationTests2/build/keep-going/p/P.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/keep-going/p/P.hs @@ -0,0 +1,4 @@ +module P where + +p :: Int +p = this_is_not_expected_to_compile diff --git a/tests/IntegrationTests2/build/keep-going/p/p.cabal b/tests/IntegrationTests2/build/keep-going/p/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/keep-going/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base diff --git a/tests/IntegrationTests2/build/keep-going/q/Q.hs b/tests/IntegrationTests2/build/keep-going/q/Q.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/keep-going/q/Q.hs @@ -0,0 +1,4 @@ +module Q where + +q :: Int +q = 42 diff --git a/tests/IntegrationTests2/build/keep-going/q/q.cabal b/tests/IntegrationTests2/build/keep-going/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/keep-going/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base + diff --git a/tests/IntegrationTests2/build/setup-custom1/A.hs b/tests/IntegrationTests2/build/setup-custom1/A.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom1/A.hs @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 42 diff --git a/tests/IntegrationTests2/build/setup-custom1/Setup.hs b/tests/IntegrationTests2/build/setup-custom1/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom1/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain >> writeFile "marker" "ok" diff --git a/tests/IntegrationTests2/build/setup-custom1/a.cabal b/tests/IntegrationTests2/build/setup-custom1/a.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom1/a.cabal @@ -0,0 +1,13 @@ +name: a +version: 0.1 +build-type: Custom +cabal-version: >= 1.10 + +-- explicit setup deps: +custom-setup + setup-depends: base, Cabal >= 1.18 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/tests/IntegrationTests2/build/setup-custom2/A.hs b/tests/IntegrationTests2/build/setup-custom2/A.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom2/A.hs @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 42 diff --git a/tests/IntegrationTests2/build/setup-custom2/Setup.hs b/tests/IntegrationTests2/build/setup-custom2/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom2/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain >> writeFile "marker" "ok" diff --git a/tests/IntegrationTests2/build/setup-custom2/a.cabal b/tests/IntegrationTests2/build/setup-custom2/a.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-custom2/a.cabal @@ -0,0 +1,11 @@ +name: a +version: 0.1 +build-type: Custom +cabal-version: >= 1.10 + +-- no explicit setup deps + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/tests/IntegrationTests2/build/setup-simple/A.hs b/tests/IntegrationTests2/build/setup-simple/A.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-simple/A.hs @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 42 diff --git a/tests/IntegrationTests2/build/setup-simple/Setup.hs b/tests/IntegrationTests2/build/setup-simple/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-simple/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/IntegrationTests2/build/setup-simple/a.cabal b/tests/IntegrationTests2/build/setup-simple/a.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/setup-simple/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/tests/IntegrationTests2/exception/bad-config/cabal.project b/tests/IntegrationTests2/exception/bad-config/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/bad-config/cabal.project @@ -0,0 +1,4 @@ +packages: + +package foo + ghc-location: bar diff --git a/tests/IntegrationTests2/exception/build/Main.hs b/tests/IntegrationTests2/exception/build/Main.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/build/Main.hs @@ -0,0 +1,1 @@ +main = thisNameDoesNotExist diff --git a/tests/IntegrationTests2/exception/build/a.cabal b/tests/IntegrationTests2/exception/build/a.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/build/a.cabal @@ -0,0 +1,8 @@ +name: a +version: 1 +build-type: Simple +cabal-version: >= 1.2 + +executable a + main-is: Main.hs + build-depends: base diff --git a/tests/IntegrationTests2/exception/configure/a.cabal b/tests/IntegrationTests2/exception/configure/a.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/configure/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 1 +build-type: Simple +-- This used to be a blank package with no components, +-- but I refactored new-build so that if a package has +-- no buildable components, we skip configuring it. +-- So put in a (failing) component so that we try to +-- configure. +executable a diff --git a/tests/IntegrationTests2/exception/no-pkg/empty.in b/tests/IntegrationTests2/exception/no-pkg/empty.in new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/no-pkg/empty.in @@ -0,0 +1,1 @@ +this is just here to ensure the source control creates the dir diff --git a/tests/IntegrationTests2/exception/no-pkg2/cabal.project b/tests/IntegrationTests2/exception/no-pkg2/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/exception/no-pkg2/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/regression/3324/cabal.project b/tests/IntegrationTests2/regression/3324/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/regression/3324/cabal.project @@ -0,0 +1,1 @@ +packages: p q diff --git a/tests/IntegrationTests2/regression/3324/p/P.hs b/tests/IntegrationTests2/regression/3324/p/P.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/regression/3324/p/P.hs @@ -0,0 +1,4 @@ +module P where + +p :: Int +p = 42 diff --git a/tests/IntegrationTests2/regression/3324/p/p.cabal b/tests/IntegrationTests2/regression/3324/p/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/regression/3324/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base diff --git a/tests/IntegrationTests2/regression/3324/q/Q.hs b/tests/IntegrationTests2/regression/3324/q/Q.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/regression/3324/q/Q.hs @@ -0,0 +1,6 @@ +module Q where + +import P + +q :: Int +q = p diff --git a/tests/IntegrationTests2/regression/3324/q/q.cabal b/tests/IntegrationTests2/regression/3324/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/regression/3324/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base + -- missing a dep on p here, so expect failure initially diff --git a/tests/IntegrationTests2/targets/all-disabled/cabal.project b/tests/IntegrationTests2/targets/all-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/all-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/targets/all-disabled/p.cabal b/tests/IntegrationTests2/targets/all-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/all-disabled/p.cabal @@ -0,0 +1,23 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, filepath + buildable: False + +executable buildable-false + main-is: Main.hs + buildable: False + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project b/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ ./q/ diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal b/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +benchmark solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base + diff --git a/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal b/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal @@ -0,0 +1,10 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +benchmark buildable-false + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: False + diff --git a/tests/IntegrationTests2/targets/complex/cabal.project b/tests/IntegrationTests2/targets/complex/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/complex/cabal.project @@ -0,0 +1,1 @@ +packages: q/ diff --git a/tests/IntegrationTests2/targets/complex/q/Q.hs b/tests/IntegrationTests2/targets/complex/q/Q.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/complex/q/Q.hs diff --git a/tests/IntegrationTests2/targets/complex/q/q.cabal b/tests/IntegrationTests2/targets/complex/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/complex/q/q.cabal @@ -0,0 +1,22 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, filepath + +executable buildable-false + main-is: Main.hs + buildable: False + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + diff --git a/tests/IntegrationTests2/targets/empty-pkg/cabal.project b/tests/IntegrationTests2/targets/empty-pkg/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/empty-pkg/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/targets/empty-pkg/p.cabal b/tests/IntegrationTests2/targets/empty-pkg/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/empty-pkg/p.cabal @@ -0,0 +1,5 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + diff --git a/tests/IntegrationTests2/targets/empty/cabal.project b/tests/IntegrationTests2/targets/empty/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/empty/cabal.project @@ -0,0 +1,1 @@ +packages: diff --git a/tests/IntegrationTests2/targets/empty/foo.hs b/tests/IntegrationTests2/targets/empty/foo.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/empty/foo.hs diff --git a/tests/IntegrationTests2/targets/exes-disabled/cabal.project b/tests/IntegrationTests2/targets/exes-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/exes-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal b/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +executable p + main-is: P.hs + build-depends: base + buildable: False diff --git a/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal b/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +executable q + main-is: Q.hs + build-depends: base + buildable: False diff --git a/tests/IntegrationTests2/targets/libs-disabled/cabal.project b/tests/IntegrationTests2/targets/libs-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/libs-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal b/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base + buildable: False diff --git a/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal b/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base + buildable: False diff --git a/tests/IntegrationTests2/targets/multiple-exes/cabal.project b/tests/IntegrationTests2/targets/multiple-exes/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-exes/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/targets/multiple-exes/p.cabal b/tests/IntegrationTests2/targets/multiple-exes/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-exes/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +executable p1 + main-is: P1.hs + build-depends: base + +executable p2 + main-is: P2.hs + build-depends: base diff --git a/tests/IntegrationTests2/targets/multiple-libs/cabal.project b/tests/IntegrationTests2/targets/multiple-libs/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-libs/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal b/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base diff --git a/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal b/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base diff --git a/tests/IntegrationTests2/targets/multiple-tests/cabal.project b/tests/IntegrationTests2/targets/multiple-tests/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-tests/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/targets/multiple-tests/p.cabal b/tests/IntegrationTests2/targets/multiple-tests/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/multiple-tests/p.cabal @@ -0,0 +1,14 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite p1 + type: exitcode-stdio-1.0 + main-is: P1.hs + build-depends: base + +test-suite p2 + type: exitcode-stdio-1.0 + main-is: P2.hs + build-depends: base diff --git a/tests/IntegrationTests2/targets/simple/P.hs b/tests/IntegrationTests2/targets/simple/P.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/P.hs diff --git a/tests/IntegrationTests2/targets/simple/cabal.project b/tests/IntegrationTests2/targets/simple/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/cabal.project @@ -0,0 +1,1 @@ +packages: ./ q/ diff --git a/tests/IntegrationTests2/targets/simple/p.cabal b/tests/IntegrationTests2/targets/simple/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base + +executable pexe + main-is: Main.hs + other-modules: PMain diff --git a/tests/IntegrationTests2/targets/simple/q/QQ.hs b/tests/IntegrationTests2/targets/simple/q/QQ.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/q/QQ.hs diff --git a/tests/IntegrationTests2/targets/simple/q/q.cabal b/tests/IntegrationTests2/targets/simple/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/simple/q/q.cabal @@ -0,0 +1,12 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: QQ + build-depends: base + +executable qexe + main-is: Main.hs + other-modules: QMain diff --git a/tests/IntegrationTests2/targets/test-only/p.cabal b/tests/IntegrationTests2/targets/test-only/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/test-only/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +test-suite pexe + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: PMain diff --git a/tests/IntegrationTests2/targets/tests-disabled/cabal.project b/tests/IntegrationTests2/targets/tests-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/tests-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ ./q/ diff --git a/tests/IntegrationTests2/targets/tests-disabled/p.cabal b/tests/IntegrationTests2/targets/tests-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/tests-disabled/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +test-suite user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base + diff --git a/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal b/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal @@ -0,0 +1,10 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite buildable-false + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: False + diff --git a/tests/IntegrationTests2/targets/variety/cabal.project b/tests/IntegrationTests2/targets/variety/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/variety/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/tests/IntegrationTests2/targets/variety/p.cabal b/tests/IntegrationTests2/targets/variety/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/variety/p.cabal @@ -0,0 +1,27 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: P + build-depends: base + +foreign-library libp + type: native-shared + other-modules: FLib + +executable an-exe + main-is: Main.hs + other-modules: AModule + +test-suite a-testsuite + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: AModule + +benchmark a-benchmark + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: AModule + diff --git a/tests/MemoryUsageTests.hs b/tests/MemoryUsageTests.hs new file mode 100644 --- /dev/null +++ b/tests/MemoryUsageTests.hs @@ -0,0 +1,15 @@ +module MemoryUsageTests where + +import Test.Tasty + +import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage + +tests :: TestTree +tests = + testGroup "Memory Usage" + [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage" + UnitTests.Distribution.Solver.Modular.MemoryUsage.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/tests/SolverQuickCheck.hs b/tests/SolverQuickCheck.hs new file mode 100644 --- /dev/null +++ b/tests/SolverQuickCheck.hs @@ -0,0 +1,16 @@ +module SolverQuickCheck where + +import Test.Tasty + +import qualified UnitTests.Distribution.Solver.Modular.QuickCheck + + +tests :: TestTree +tests = + testGroup "Solver QuickCheck" + [ testGroup "UnitTests.Distribution.Solver.Modular.QuickCheck" + UnitTests.Distribution.Solver.Modular.QuickCheck.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -1,31 +1,31 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Main - where +module UnitTests where import Test.Tasty -import Control.Monad -import Data.Time.Clock -import System.FilePath - import Distribution.Simple.Utils import Distribution.Verbosity -import Distribution.Client.Compat.Time +import Distribution.Compat.Time -import qualified UnitTests.Distribution.Client.Compat.Time -import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ -import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver +import qualified UnitTests.Distribution.Solver.Modular.PSQ +import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ +import qualified UnitTests.Distribution.Solver.Modular.Solver +import qualified UnitTests.Distribution.Solver.Modular.RetryLog import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Sandbox import qualified UnitTests.Distribution.Client.Sandbox.Timestamp +import qualified UnitTests.Distribution.Client.Store import qualified UnitTests.Distribution.Client.Tar import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.ProjectConfig +import qualified UnitTests.Distribution.Client.JobControl +import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp +import qualified UnitTests.Distribution.Client.InstallPlan import UnitTests.Options @@ -38,12 +38,14 @@ else mtimeChangeCalibrated in testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Client.Compat.Time" $ - UnitTests.Distribution.Client.Compat.Time.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ" - UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests - , testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver" - UnitTests.Distribution.Client.Dependency.Modular.Solver.tests + [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ" + UnitTests.Distribution.Solver.Modular.PSQ.tests + , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" + UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests + , testGroup "UnitTests.Distribution.Solver.Modular.Solver" + UnitTests.Distribution.Solver.Modular.Solver.tests + , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog" + UnitTests.Distribution.Solver.Modular.RetryLog.tests , testGroup "UnitTests.Distribution.Client.FileMonitor" $ UnitTests.Distribution.Client.FileMonitor.tests mtimeChange , testGroup "UnitTests.Distribution.Client.Glob" @@ -54,6 +56,8 @@ UnitTests.Distribution.Client.Sandbox.tests , testGroup "Distribution.Client.Sandbox.Timestamp" UnitTests.Distribution.Client.Sandbox.Timestamp.tests + , testGroup "Distribution.Client.Store" + UnitTests.Distribution.Client.Store.tests , testGroup "Distribution.Client.Tar" UnitTests.Distribution.Client.Tar.tests , testGroup "Distribution.Client.Targets" @@ -62,45 +66,25 @@ UnitTests.Distribution.Client.UserConfig.tests , testGroup "UnitTests.Distribution.Client.ProjectConfig" UnitTests.Distribution.Client.ProjectConfig.tests + , testGroup "UnitTests.Distribution.Client.JobControl" + UnitTests.Distribution.Client.JobControl.tests + , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" + UnitTests.Distribution.Client.IndexUtils.Timestamp.tests + , testGroup "UnitTests.Distribution.Client.InstallPlan" + UnitTests.Distribution.Client.InstallPlan.tests ] main :: IO () main = do - mtimeChangeDelay <- calibrateMtimeChangeDelay + (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay + let toMillis :: Int -> Double + toMillis x = fromIntegral x / 1000.0 + notice normal $ "File modification time resolution calibration completed, " + ++ "maximum delay observed: " + ++ (show . toMillis $ mtimeChange ) ++ " ms. " + ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') + ++ " for test runs." defaultMainWithIngredients (includingOptions extraOptions : defaultIngredients) - (tests mtimeChangeDelay) - --- Based on code written by Neill Mitchell for Shake. See --- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller --- than 10 ms, but never larger than 1 second. -calibrateMtimeChangeDelay :: IO Int -calibrateMtimeChangeDelay = do - withTempDirectory silent "." "calibration-" $ \dir -> do - let fileName = dir "probe" - mtimes <- forM [1..25] $ \(i::Int) -> time $ do - writeFile fileName $ show i - t0 <- getModTime fileName - let spin j = do - writeFile fileName $ show (i,j) - t1 <- getModTime fileName - unless (t0 < t1) (spin $ j + 1) - spin (0::Int) - let mtimeChange = maximum mtimes - mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 - notice normal $ "File modification time resolution calibration completed, " - ++ "maximum delay observed: " - ++ (show . toMillis $ mtimeChange ) ++ " ms. " - ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') - ++ " for test runs." - return mtimeChange' - where - toMillis :: Int -> Double - toMillis x = fromIntegral x / 1000.0 + (tests mtimeChange') - time :: IO () -> IO Int - time act = do - t0 <- getCurrentTime - act - t1 <- getCurrentTime - return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds diff --git a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs --- a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -21,6 +21,7 @@ import Control.Monad import Distribution.Version +import Distribution.Types.Dependency import Distribution.Package import Distribution.System import Distribution.Verbosity @@ -30,6 +31,8 @@ import Distribution.Utils.NubList +import Distribution.Client.IndexUtils.Timestamp + import Test.QuickCheck @@ -67,7 +70,6 @@ arbitraryShortToken :: Gen String arbitraryShortToken = getShortToken <$> arbitrary -#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary Version where arbitrary = do branch <- shortListOf1 4 $ @@ -75,14 +77,11 @@ ,(3, return 1) ,(2, return 2) ,(1, return 3)] - return (Version branch []) -- deliberate [] + return (mkVersion branch) where - shrink (Version branch []) = - [ Version branch' [] | branch' <- shrink branch, not (null branch') ] - shrink (Version branch _tags) = - [ Version branch [] ] -#endif + shrink ver = [ mkVersion branch' | branch' <- shrink (versionNumbers ver) + , not (null branch') ] instance Arbitrary VersionRange where arbitrary = canonicaliseVersionRange <$> sized verRangeExp @@ -113,7 +112,7 @@ canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals instance Arbitrary PackageName where - arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent + arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent where nameComponent = shortListOf1 5 (elements packageChars) `suchThat` (not . all isDigit) @@ -172,3 +171,10 @@ arbitrary = NoShrink <$> arbitrary shrink _ = [] +instance Arbitrary Timestamp where + arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary + +instance Arbitrary IndexState where + arbitrary = frequency [ (1, pure IndexStateHead) + , (50, IndexStateTime <$> arbitrary) + ] diff --git a/tests/UnitTests/Distribution/Client/Compat/Time.hs b/tests/UnitTests/Distribution/Client/Compat/Time.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Compat/Time.hs +++ /dev/null @@ -1,49 +0,0 @@ -module UnitTests.Distribution.Client.Compat.Time (tests) where - -import Control.Concurrent (threadDelay) -import System.FilePath - -import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity - -import Distribution.Client.Compat.Time - -import Test.Tasty -import Test.Tasty.HUnit - -tests :: Int -> [TestTree] -tests mtimeChange = - [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange - , testCase "getCurTime works as expected" $ getCurTimeTest mtimeChange - ] - -getModTimeTest :: Int -> Assertion -getModTimeTest mtimeChange = - withTempDirectory silent "." "getmodtime-" $ \dir -> do - let fileName = dir "foo" - writeFile fileName "bar" - t0 <- getModTime fileName - threadDelay mtimeChange - writeFile fileName "baz" - t1 <- getModTime fileName - assertBool "expected different file mtimes" (t1 > t0) - - -getCurTimeTest :: Int -> Assertion -getCurTimeTest mtimeChange = - withTempDirectory silent "." "getmodtime-" $ \dir -> do - let fileName = dir "foo" - writeFile fileName "bar" - t0 <- getModTime fileName - threadDelay mtimeChange - t1 <- getCurTime - assertBool("expected file mtime (" ++ show t0 - ++ ") to be earlier than current time (" ++ show t1 ++ ")") - (t0 < t1) - - threadDelay mtimeChange - writeFile fileName "baz" - t2 <- getModTime fileName - assertBool ("expected current time (" ++ show t1 - ++ ") to be earlier than file mtime (" ++ show t2 ++ ")") - (t1 < t2) diff --git a/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | DSL for testing the modular solver -module UnitTests.Distribution.Client.Dependency.Modular.DSL ( - ExampleDependency(..) - , Dependencies(..) - , ExTest(..) - , ExPreference(..) - , ExampleDb - , ExampleVersionRange - , ExamplePkgVersion - , exAv - , exInst - , exFlag - , exResolve - , extractInstallPlan - , withSetupDeps - , withTest - , withTests - ) where - --- base -import Data.Either (partitionEithers) -import Data.Maybe (catMaybes) -import Data.List (nub) -import Data.Monoid -import Data.Version -import qualified Data.Map as Map - --- Cabal -import qualified Distribution.Compiler as C -import qualified Distribution.InstalledPackageInfo as C -import qualified Distribution.Package as C - hiding (HasUnitId(..)) -import qualified Distribution.PackageDescription as C -import qualified Distribution.Simple.PackageIndex as C.PackageIndex -import qualified Distribution.System as C -import qualified Distribution.Version as C -import Language.Haskell.Extension (Extension(..), Language) - --- cabal-install -import Distribution.Client.ComponentDeps (ComponentDeps) -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as CI.InstallPlan -import qualified Distribution.Client.PackageIndex as CI.PackageIndex -import qualified Distribution.Client.PkgConfigDb as PC -import qualified Distribution.Client.ComponentDeps as CD - -{------------------------------------------------------------------------------- - Example package database DSL - - In order to be able to set simple examples up quickly, we define a very - simple version of the package database here explicitly designed for use in - tests. - - The design of `ExampleDb` takes the perspective of the solver, not the - perspective of the package DB. This makes it easier to set up tests for - various parts of the solver, but makes the mapping somewhat awkward, because - it means we first map from "solver perspective" `ExampleDb` to the package - database format, and then the modular solver internally in `IndexConversion` - maps this back to the solver specific data structures. - - IMPLEMENTATION NOTES - -------------------- - - TODO: Perhaps these should be made comments of the corresponding data type - definitions. For now these are just my own conclusions and may be wrong. - - * The difference between `GenericPackageDescription` and `PackageDescription` - is that `PackageDescription` describes a particular _configuration_ of a - package (for instance, see documentation for `checkPackage`). A - `GenericPackageDescription` can be turned into a `PackageDescription` in - two ways: - - a. `finalizePackageDescription` does the proper translation, by taking - into account the platform, available dependencies, etc. and picks a - flag assignment (or gives an error if no flag assignment can be found) - b. `flattenPackageDescription` ignores flag assignment and just joins all - components together. - - The slightly odd thing is that a `GenericPackageDescription` contains a - `PackageDescription` as a field; both of the above functions do the same - thing: they take the embedded `PackageDescription` as a basis for the result - value, but override `library`, `executables`, `testSuites`, `benchmarks` - and `buildDepends`. - * The `condTreeComponents` fields of a `CondTree` is a list of triples - `(condition, then-branch, else-branch)`, where the `else-branch` is - optional. --------------------------------------------------------------------------------} - -type ExamplePkgName = String -type ExamplePkgVersion = Int -type ExamplePkgHash = String -- for example "installed" packages -type ExampleFlagName = String -type ExampleTestName = String -type ExampleVersionRange = C.VersionRange -data Dependencies = NotBuildable | Buildable [ExampleDependency] - -data ExampleDependency = - -- | Simple dependency on any version - ExAny ExamplePkgName - - -- | Simple dependency on a fixed version - | ExFix ExamplePkgName ExamplePkgVersion - - -- | Dependencies indexed by a flag - | ExFlag ExampleFlagName Dependencies Dependencies - - -- | Dependency on a language extension - | ExExt Extension - - -- | Dependency on a language version - | ExLang Language - - -- | Dependency on a pkg-config package - | ExPkg (ExamplePkgName, ExamplePkgVersion) - -data ExTest = ExTest ExampleTestName [ExampleDependency] - -exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] - -> ExampleDependency -exFlag n t e = ExFlag n (Buildable t) (Buildable e) - -data ExPreference = ExPref String ExampleVersionRange - -data ExampleAvailable = ExAv { - exAvName :: ExamplePkgName - , exAvVersion :: ExamplePkgVersion - , exAvDeps :: ComponentDeps [ExampleDependency] - } - -exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] - -> ExampleAvailable -exAv n v ds = ExAv { exAvName = n, exAvVersion = v - , exAvDeps = CD.fromLibraryDeps ds } - -withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable -withSetupDeps ex setupDeps = ex { - exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps - } - -withTest :: ExampleAvailable -> ExTest -> ExampleAvailable -withTest ex test = withTests ex [test] - -withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable -withTests ex tests = - let testCDs = CD.fromList [(CD.ComponentTest name, deps) - | ExTest name deps <- tests] - in ex { exAvDeps = exAvDeps ex <> testCDs } - -data ExampleInstalled = ExInst { - exInstName :: ExamplePkgName - , exInstVersion :: ExamplePkgVersion - , exInstHash :: ExamplePkgHash - , exInstBuildAgainst :: [ExampleInstalled] - } - -exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash - -> [ExampleInstalled] -> ExampleInstalled -exInst = ExInst - -type ExampleDb = [Either ExampleInstalled ExampleAvailable] - -type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a - -exDbPkgs :: ExampleDb -> [ExamplePkgName] -exDbPkgs = map (either exInstName exAvName) - -exAvSrcPkg :: ExampleAvailable -> SourcePackage -exAvSrcPkg ex = - let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex)) - testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] - in SourcePackage { - packageInfoId = exAvPkgId ex - , packageSource = LocalTarballPackage "<>" - , 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 deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs +++ /dev/null @@ -1,22 +0,0 @@ -module UnitTests.Distribution.Client.Dependency.Modular.PSQ ( - tests - ) where - -import Distribution.Client.Dependency.Modular.PSQ - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = [ testProperty "splitsAltImplementation" splitsTest - ] - --- | Original splits implementation -splits' :: PSQ k a -> PSQ k (a, PSQ k a) -splits' xs = - casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys))) - -splitsTest :: [(Int, Int)] -> Bool -splitsTest psq = splits' (PSQ psq) == splits (PSQ psq) diff --git a/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +++ /dev/null @@ -1,805 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests) - where - --- base -import Control.Monad -import Data.List (isInfixOf) - -import qualified Data.Version as V -import qualified Distribution.Version as V - --- test-framework -import Test.Tasty as TF -import Test.Tasty.HUnit (testCase, assertEqual, assertBool) - --- Cabal -import Language.Haskell.Extension ( Extension(..) - , KnownExtension(..), Language(..)) - --- cabal-install -import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) -import UnitTests.Distribution.Client.Dependency.Modular.DSL -import UnitTests.Options - -tests :: [TF.TestTree] -tests = [ - testGroup "Simple dependencies" [ - runTest $ mkTest db1 "alreadyInstalled" ["A"] (SolverSuccess []) - , runTest $ mkTest db1 "installLatest" ["B"] (SolverSuccess [("B", 2)]) - , runTest $ mkTest db1 "simpleDep1" ["C"] (SolverSuccess [("B", 1), ("C", 1)]) - , runTest $ mkTest db1 "simpleDep2" ["D"] (SolverSuccess [("B", 2), ("D", 1)]) - , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (SolverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (SolverSuccess [("B", 1), ("C", 1), ("E", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (SolverSuccess [("B", 2), ("D", 1), ("E", 1)]) - , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (SolverSuccess [("B", 1), ("E", 1), ("F", 1)]) - , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (SolverSuccess [("B", 2), ("E", 1), ("G", 1)]) - , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure - , runTest $ mkTest db21 "unknownPackage1" ["A"] (SolverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest db22 "unknownPackage2" ["A"] (SolverFailure (isInfixOf "unknown package: C")) - ] - , testGroup "Flagged dependencies" [ - runTest $ mkTest db3 "forceFlagOn" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db3 "forceFlagOff" ["D"] (SolverSuccess [("A", 2), ("B", 1), ("D", 1)]) - , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) - ] - , testGroup "Stanzas" [ - runTest $ mkTest db5 "simpleTest1" ["C"] (SolverSuccess [("A", 2), ("C", 1)]) - , runTest $ mkTest db5 "simpleTest2" ["D"] anySolverFailure - , runTest $ mkTest db5 "simpleTest3" ["E"] (SolverSuccess [("A", 1), ("E", 1)]) - , runTest $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO - , runTest $ mkTest db5 "simpleTest5" ["G"] (SolverSuccess [("A", 2), ("G", 1)]) - , runTest $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure - , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (SolverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) - , runTest $ mkTest db6 "depsWithTests1" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) - ] - , testGroup "Setup dependencies" [ - runTest $ mkTest db7 "setupDeps1" ["B"] (SolverSuccess [("A", 2), ("B", 1)]) - , runTest $ mkTest db7 "setupDeps2" ["C"] (SolverSuccess [("A", 2), ("C", 1)]) - , runTest $ mkTest db7 "setupDeps3" ["D"] (SolverSuccess [("A", 1), ("D", 1)]) - , runTest $ mkTest db7 "setupDeps4" ["E"] (SolverSuccess [("A", 1), ("A", 2), ("E", 1)]) - , runTest $ mkTest db7 "setupDeps5" ["F"] (SolverSuccess [("A", 1), ("A", 2), ("F", 1)]) - , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (SolverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (SolverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) - , runTest $ mkTest db10 "setupDeps8" ["C"] (SolverSuccess [("C", 1)]) - , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) - ] - , testGroup "Base shim" [ - runTest $ mkTest db11 "baseShim1" ["A"] (SolverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim2" ["A"] (SolverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim3" ["B"] (SolverSuccess [("B", 1)]) - , runTest $ mkTest db12 "baseShim4" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure - , runTest $ mkTest db12 "baseShim6" ["E"] (SolverSuccess [("E", 1), ("syb", 2)]) - ] - , testGroup "Cycles" [ - runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure - , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure - , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (SolverSuccess [("C", 1), ("E", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (SolverSuccess [("C", 2), ("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (SolverSuccess [("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (SolverSuccess [("C", 2), ("D", 1), ("E", 1)]) - ] - , testGroup "Extensions" [ - runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (SolverSuccess [("A",1)]) - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (SolverSuccess [("A",1),("B",1), ("C",1)]) - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (SolverSuccess [("A",1),("B",1),("C",1),("E",1)]) - ] - , testGroup "Languages" [ - runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (SolverSuccess [("A",1)]) - , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (SolverSuccess [("A",1),("B",1),("C",1)]) - ] - - , testGroup "Soft Constraints" [ - runTest $ soft [ ExPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (SolverSuccess [("A", 1)]) - , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (SolverSuccess [("A", 2)]) - , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2 - , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (SolverSuccess [("A", 1)]) - , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1 - , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (SolverSuccess [("A", 1)]) - , runTest $ soft [ ExPref "A" $ mkvrThis 1 - , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (SolverSuccess [("A", 2)]) - , runTest $ soft [ ExPref "A" $ mkvrThis 1 - , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (SolverSuccess [("A", 1)]) - ] - , testGroup "Buildable Field" [ - testBuildable "avoid building component with unknown dependency" (ExAny "unknown") - , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown")) - , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown")) - , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (SolverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)]) - , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (SolverSuccess [("A", 1), ("B", 2)]) - ] - , testGroup "Pkg-config dependencies" [ - runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (SolverSuccess [("A", 1), ("B", 2), ("C", 1)]) - ] - , testGroup "Independent goals" [ - runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) - , runTest $ indep $ mkTest db17 "indepGoals2" ["A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) - , runTest $ indep $ mkTest db19 "indepGoals3" ["D", "E", "F"] anySolverFailure -- The target order is important. - , runTest $ indep $ mkTest db20 "indepGoals4" ["C", "A", "B"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) - , runTest $ indep $ mkTest db23 "indepGoals5" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]) - , runTest $ indep $ mkTest db24 "indepGoals6" ["X", "Y"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]) - ] - ] - where - indep test = test { testIndepGoals = True } - soft prefs test = test { testSoftConstraints = prefs } - mkvrThis = V.thisVersion . makeV - mkvrOrEarlier = V.orEarlierVersion . makeV - makeV v = V.Version [v,0,0] [] - -{------------------------------------------------------------------------------- - Solver tests --------------------------------------------------------------------------------} - -data SolverTest = SolverTest { - testLabel :: String - , testTargets :: [String] - , testResult :: SolverResult - , testIndepGoals :: Bool - , testSoftConstraints :: [ExPreference] - , testDb :: ExampleDb - , testSupportedExts :: Maybe [Extension] - , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb - } - --- | Result of a solver test. -data SolverResult = - SolverSuccess [(String, Int)] -- ^ succeeds with given plan - | SolverFailure (String -> Bool) -- ^ fails, and the error message satisfies the predicate - --- | Can be used for test cases where we just want to verify that --- they fail, but do not care about the error message. -anySolverFailure :: SolverResult -anySolverFailure = SolverFailure (const True) - -mkTest :: ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTest = mkTestExtLangPC Nothing Nothing [] - -mkTestExts :: [Extension] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] - -mkTestLangs :: [Language] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] - -mkTestPCDepends :: [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb - -mkTestExtLangPC :: Maybe [Extension] - -> Maybe [Language] - -> [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { - testLabel = label - , testTargets = targets - , testResult = result - , testIndepGoals = False - , testSoftConstraints = [] - , testDb = db - , testSupportedExts = exts - , testSupportedLangs = langs - , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb - } - -runTest :: SolverTest -> TF.TestTree -runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> - testCase testLabel $ do - let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs - testPkgConfigDb testTargets testIndepGoals testSoftConstraints - when showSolverLog $ mapM_ putStrLn _msgs - case result of - Left err -> assertBool ("Unexpected error:\n" ++ err) (check testResult err) - Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) - where - toMaybe :: SolverResult -> Maybe ([(String, Int)]) - toMaybe (SolverSuccess plan) = Just plan - toMaybe (SolverFailure _ ) = Nothing - - check :: SolverResult -> (String -> Bool) - check (SolverFailure f) = f - check _ = const False - -{------------------------------------------------------------------------------- - Specific example database for the tests --------------------------------------------------------------------------------} - -db1 :: ExampleDb -db1 = - let a = exInst "A" 1 "A-1" [] - in [ Left a - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExFix "B" 1] - , Right $ exAv "D" 1 [ExFix "B" 2] - , Right $ exAv "E" 1 [ExAny "B"] - , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"] - , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"] - , Right $ exAv "Z" 1 [] - ] - --- In this example, we _can_ install C and D as independent goals, but we have --- to pick two diferent versions for B (arbitrarily) -db2 :: ExampleDb -db2 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1] - , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2] - ] - -db3 :: ExampleDb -db3 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]] - , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] - ] - --- | Like db3, but the flag picks a different package rather than a --- different package version --- --- In db3 we cannot install C and D as independent goals because: --- --- * The multiple instance restriction says C and D _must_ share B --- * Since C relies on A-1, C needs B to be compiled with flagB on --- * Since D relies on A-2, D needs B to be compiled with flagB off --- * Hence C and D have incompatible requirements on B's flags. --- --- However, _even_ if we don't check explicitly that we pick the same flag --- assignment for 0.B and 1.B, we will still detect the problem because --- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to --- 1.A and therefore we cannot link 0.B to 1.B. --- --- In db4 the situation however is trickier. We again cannot install --- packages C and D as independent goals because: --- --- * As above, the multiple instance restriction says that C and D _must_ share B --- * Since C relies on Ax-2, it requires B to be compiled with flagB off --- * Since D relies on Ay-2, it requires B to be compiled with flagB on --- * Hence C and D have incompatible requirements on B's flags. --- --- But now this requirement is more indirect. If we only check dependencies --- we don't see the problem: --- --- * We link 0.B to 1.B --- * 0.B relies on Ay-1 --- * 1.B relies on Ax-1 --- --- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since --- we only ever assign to one of these, these constraints are never broken. -db4 :: ExampleDb -db4 = [ - Right $ exAv "Ax" 1 [] - , Right $ exAv "Ax" 2 [] - , Right $ exAv "Ay" 1 [] - , Right $ exAv "Ay" 2 [] - , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] - , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] - ] - --- | Some tests involving testsuites --- --- Note that in this test framework test suites are always enabled; if you --- want to test without test suites just set up a test database without --- test suites. --- --- * C depends on A (through its test suite) --- * D depends on B-2 (through its test suite), but B-2 is unavailable --- * E depends on A-1 directly and on A through its test suite. We prefer --- to use A-1 for the test suite in this case. --- * F depends on A-1 directly and on A-2 through its test suite. In this --- case we currently fail to install F, although strictly speaking --- test suites should be considered independent goals. --- * G is like E, but for version A-2. This means that if we cannot install --- E and G together, unless we regard them as independent goals. -db5 :: ExampleDb -db5 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] - , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"] - , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2] - , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"] - , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2] - , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"] - ] - --- Now the _dependencies_ have test suites --- --- * Installing C is a simple example. C wants version 1 of A, but depends on --- B, and B's testsuite depends on an any version of A. In this case we prefer --- to link (if we don't regard test suites as independent goals then of course --- linking here doesn't even come into it). --- * Installing [C, D] means that we prefer to link B -- depending on how we --- set things up, this means that we should also link their test suites. -db6 :: ExampleDb -db6 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"] - , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] - , Right $ exAv "D" 1 [ExAny "B"] - ] - --- Packages with setup dependencies --- --- Install.. --- * B: Simple example, just make sure setup deps are taken into account at all --- * C: Both the package and the setup script depend on any version of A. --- In this case we prefer to link --- * D: Variation on C.1 where the package requires a specific (not latest) --- version but the setup dependency is not fixed. Again, we prefer to --- link (picking the older version) --- * E: Variation on C.2 with the setup dependency the more inflexible. --- Currently, in this case we do not see the opportunity to link because --- we consider setup dependencies after normal dependencies; we will --- pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick --- A.1 instead. This isn't so easy to fix (if we want to fix it at all); --- in particular, considering setup dependencies _before_ other deps is --- not an improvement, because in general we would prefer to link setup --- setups to package deps, rather than the other way around. (For example, --- if we change this ordering then the test for D would start to install --- two versions of A). --- * F: The package and the setup script depend on different versions of A. --- This will only work if setup dependencies are considered independent. -db7 :: ExampleDb -db7 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "A" ] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "E" 1 [ExAny "A" ] `withSetupDeps` [ExFix "A" 1] - , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] - ] - --- If we install C and D together (not as independent goals), we need to build --- both B.1 and B.2, both of which depend on A. -db8 :: ExampleDb -db8 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1] - , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2] - ] - --- Extended version of `db8` so that we have nested setup dependencies -db9 :: ExampleDb -db9 = db8 ++ [ - Right $ exAv "E" 1 [ExAny "C"] - , Right $ exAv "E" 2 [ExAny "D"] - , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1] - , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2] - ] - --- Multiple already-installed packages with inter-dependencies, and one package --- (C) that depends on package A-1 for its setup script and package A-2 as a --- library dependency. -db10 :: ExampleDb -db10 = - let rts = exInst "rts" 1 "rts-inst" [] - ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts] - base = exInst "base" 1 "base-inst" [rts, ghc_prim] - a1 = exInst "A" 1 "A1-inst" [base] - a2 = exInst "A" 2 "A2-inst" [base] - in [ - Left rts - , Left ghc_prim - , Left base - , Left a1 - , Left a2 - , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] - ] - --- | This database tests that a package's setup dependencies are correctly --- linked when the package is linked. See pull request #3268. --- --- When A and B are installed as independent goals, their dependencies on C must --- be linked, due to the single instance restriction. Since C depends on D, 0.D --- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D --- and 1.C-setup.D must be linked. However, D's two link groups must remain --- independent. The solver should be able to choose D-1 for C's library and D-2 --- for C's setup script. -dbSetupDeps :: ExampleDb -dbSetupDeps = [ - Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - --- | Tests for dealing with base shims -db11 :: ExampleDb -db11 = - let base3 = exInst "base" 3 "base-3-inst" [base4] - base4 = exInst "base" 4 "base-4-inst" [] - in [ - Left base3 - , Left base4 - , Right $ exAv "A" 1 [ExFix "base" 3] - ] - --- | Slightly more realistic version of db11 where base-3 depends on syb --- This means that if a package depends on base-3 and on syb, then they MUST --- share the version of syb --- --- * Package A relies on base-3 (which relies on base-4) --- * Package B relies on base-4 --- * Package C relies on both A and B --- * Package D relies on base-3 and on syb-2, which is not possible because --- base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier) --- * Package E relies on base-4 and on syb-2, which is fine. -db12 :: ExampleDb -db12 = - let base3 = exInst "base" 3 "base-3-inst" [base4, syb1] - base4 = exInst "base" 4 "base-4-inst" [] - syb1 = exInst "syb" 1 "syb-1-inst" [base4] - in [ - Left base3 - , Left base4 - , Left syb1 - , Right $ exAv "syb" 2 [ExFix "base" 4] - , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"] - , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"] - , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] - , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2] - , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] - ] - -db13 :: ExampleDb -db13 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "A" 3 [] - ] - --- | Database with some cycles --- --- * Simplest non-trivial cycle: A -> B and B -> A --- * There is a cycle C -> D -> C, but it can be broken by picking the --- right flag assignment. -db14 :: ExampleDb -db14 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]] - , Right $ exAv "D" 1 [ExAny "C"] - , Right $ exAv "E" 1 [] - ] - --- | Cycles through setup dependencies --- --- The first cycle is unsolvable: package A has a setup dependency on B, --- B has a regular dependency on A, and we only have a single version available --- for both. --- --- The second cycle can be broken by picking different versions: package C-2.0 --- has a setup dependency on D, and D has a regular dependency on C-*. However, --- version C-1.0 is already available (perhaps it didn't have this setup dep). --- Thus, we should be able to break this cycle even if we are installing package --- E, which explictly depends on C-2.0. -db15 :: ExampleDb -db15 = [ - -- First example (real cycle, no solution) - Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "A"] - -- Second example (cycle can be broken by picking versions carefully) - , Left $ exInst "C" 1 "C-1-inst" [] - , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] - , Right $ exAv "D" 1 [ExAny "C" ] - , Right $ exAv "E" 1 [ExFix "C" 2] - ] - --- | Check that the solver can backtrack after encountering the SIR (issue #2843) --- --- When A and B are installed as independent goals, the single instance --- restriction prevents B from depending on C. This database tests that the --- solver can backtrack after encountering the single instance restriction and --- choose the only valid flag assignment (-flagA +flagB): --- --- > flagA flagB B depends on --- > On _ C-* --- > Off On E-* <-- only valid flag assignment --- > Off Off D-2.0, C-* --- --- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D, --- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have --- C in the transitive closure of B's dependencies, because that would mean we --- would need two instances of C: one built against D-1.0 and one built against --- D-2.0. -db16 :: ExampleDb -db16 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ ExFix "D" 2 - , exFlag "flagA" - [ExAny "C"] - [exFlag "flagB" - [ExAny "E"] - [ExAny "C"]]] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - ] - --- | This database checks that when the solver discovers a constraint on a --- package's version after choosing to link that package, it can backtrack to --- try alternative versions for the linked-to package. See pull request #3327. --- --- When A and B are installed as independent goals, their dependencies on C --- must be linked. Since C depends on D, A and B's dependencies on D must also --- be linked. This test relies on the fact that the solver chooses D-2 for both --- 0.D and 1.D before it encounters the test suites' constraints. The solver --- must backtrack to try D-1 for both 0.D and 1.D. -db17 :: ExampleDb -db17 = [ - Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - --- | Issue #2834 --- When both A and B are installed as independent goals, their dependencies on --- C must be linked. The only combination of C's flags that is consistent with --- A and B's dependencies on D is -flagA +flagB. This database tests that the --- solver can backtrack to find the right combination of flags (requiring F, but --- not E or G) and apply it to both 0.C and 1.C. --- --- > flagA flagB C depends on --- > On _ D-1, E-* --- > Off On F-* <-- Only valid choice --- > Off Off D-2, G-* --- --- The single instance restriction means we cannot have one instance of C --- built against D-1 and one instance built against D-2; since A depends on --- D-1, and B depends on C-2, it is therefore important that C cannot depend --- on any version of D. -db18 :: ExampleDb -db18 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] - , Right $ exAv "C" 1 [exFlag "flagA" - [ExFix "D" 1, ExAny "E"] - [exFlag "flagB" - [ExAny "F"] - [ExFix "D" 2, ExAny "G"]]] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - , Right $ exAv "F" 1 [] - , Right $ exAv "G" 1 [] - ] - --- | Tricky test case with independent goals (issue #2842) --- --- Suppose we are installing D, E, and F as independent goals: --- --- * D depends on A-* and C-1, requiring A-1 to be built against C-1 --- * E depends on B-* and C-2, requiring B-1 to be built against C-2 --- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built --- against the same version of C, violating the single instance restriction. --- --- We can visualize this DB as: --- --- > C-1 C-2 --- > /|\ /|\ --- > / | \ / | \ --- > / | X | \ --- > | | / \ | | --- > | |/ \| | --- > | + + | --- > | | | | --- > | A B | --- > \ |\ /| / --- > \ | \ / | / --- > \| V |/ --- > D F E -db19 :: ExampleDb -db19 = [ - Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1] - , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2] - , Right $ exAv "F" 1 [ExAny "A", ExAny "B"] - ] - --- | This database tests that the solver correctly backjumps when dependencies --- of linked packages are not linked. It is an example where the conflict set --- from enforcing the single instance restriction is not sufficient. See pull --- request #3327. --- --- When C, A, and B are installed as independent goals, the solver first --- chooses 0.C-1 and 0.D-2. When choosing dependencies for A and B, it links --- 1.D and 2.D to 0.D. Finally, the solver discovers the test's constraint on --- D. It must backjump to try 1.D-1 and then link 2.D to 1.D. -db20 :: ExampleDb -db20 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "D" 1] - , Right $ exAv "C" 1 [ExFix "D" 2] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - --- | Test the trace messages that we get when a package refers to an unknown pkg --- --- TODO: Currently we don't actually test the trace messages, and this particular --- test still suceeds. The trace can only be verified by hand. -db21 :: ExampleDb -db21 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown - , Right $ exAv "B" 1 [] - ] - --- | A variant of 'db21', which actually fails. -db22 :: ExampleDb -db22 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] - ] - --- | Database for (unsuccessfully) trying to expose a bug in the handling --- of implied linking constraints. The question is whether an implied linking --- constraint should only have the introducing package in its conflict set, --- or also its link target. --- --- It turns out that as long as the Single Instance Restriction is in place, --- it does not matter, because there will aways be an option that is failing --- due to the SIR, which contains the link target in its conflict set. --- --- Even if the SIR is not in place, if there is a solution, one will always --- be found, because without the SIR, linking is always optional, but never --- necessary. --- -db23 :: ExampleDb -db23 = [ - Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - ] - --- | A simplified version of 'db23'. -db24 :: ExampleDb -db24 = [ - Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [] - , Right $ exAv "B" 2 [] - ] - -dbExts1 :: ExampleDb -dbExts1 = [ - Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] - , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B"] - , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"] - , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"] - ] - -dbLangs1 :: ExampleDb -dbLangs1 = [ - Right $ exAv "A" 1 [ExLang Haskell2010] - , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"] - , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] - ] - --- | cabal must set enable-lib to false in order to avoid the unavailable --- dependency. Flags are true by default. The flag choice causes "pkg" to --- depend on "false-dep". -testBuildable :: String -> ExampleDependency -> TestTree -testBuildable testName unavailableDep = - runTest $ mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected - where - expected = SolverSuccess [("false-dep", 1), ("pkg", 1)] - db = [ - Right $ exAv "pkg" 1 - [ unavailableDep - , ExFlag "enable-lib" (Buildable []) NotBuildable ] - `withTest` - ExTest "test" [exFlag "enable-lib" - [ExAny "true-dep"] - [ExAny "false-dep"]] - , Right $ exAv "true-dep" 1 [] - , Right $ exAv "false-dep" 1 [] - ] - --- | cabal must choose -flag1 +flag2 for "pkg", which requires packages --- "flag1-false" and "flag2-true". -dbBuildable1 :: ExampleDb -dbBuildable1 = [ - Right $ exAv "pkg" 1 - [ ExAny "unknown" - , ExFlag "flag1" (Buildable []) NotBuildable - , ExFlag "flag2" (Buildable []) NotBuildable] - `withTests` - [ ExTest "optional-test" - [ ExAny "unknown" - , ExFlag "flag1" - (Buildable []) - (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])] - , ExTest "test" [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] - , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] - ] - , Right $ exAv "flag1-true" 1 [] - , Right $ exAv "flag1-false" 1 [] - , Right $ exAv "flag2-true" 1 [] - , Right $ exAv "flag2-false" 1 [] - ] - --- | Package databases for testing @pkg-config@ dependencies. -dbPC1 :: ExampleDb -dbPC1 = [ - Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] - , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] - , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B"] - ] - --- | cabal must pick B-2 to avoid the unknown dependency. -dbBuildable2 :: ExampleDb -dbBuildable2 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "unknown"] - , Right $ exAv "B" 2 - [ ExAny "unknown" - , ExFlag "disable-lib" NotBuildable (Buildable []) - ] - , Right $ exAv "B" 3 [ExAny "unknown"] - ] diff --git a/tests/UnitTests/Distribution/Client/FileMonitor.hs b/tests/UnitTests/Distribution/Client/FileMonitor.hs --- a/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -15,7 +15,7 @@ import Distribution.Verbosity (silent) import Distribution.Client.FileMonitor -import Distribution.Client.Compat.Time +import Distribution.Compat.Time import Test.Tasty import Test.Tasty.HUnit @@ -24,6 +24,7 @@ tests :: Int -> [TestTree] tests mtimeChange = [ testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange + , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange , testCase "no monitor cache" testNoMonitorCache , testCase "corrupt monitor cache" testCorruptMonitorCache , testCase "empty monitor" testEmptyMonitor @@ -34,6 +35,7 @@ , testCase "remove file" testRemoveFile , testCase "non-existent file" testNonExistentFile , testCase "changed file type" $ testChangedFileType mtimeChange + , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange , testGroup "glob matches" [ testCase "no change" testGlobNoChange @@ -69,6 +71,8 @@ , testCase "value updated" testValueUpdated ] +-- Check the file system behaves the way we expect it to + -- we rely on file mtimes having a reasonable resolution testFileMTimeSanity :: Int -> Assertion testFileMTimeSanity mtimeChange = @@ -81,6 +85,62 @@ t2 <- getModTime (dir "a") assertBool "expected different file mtimes" (t2 > t1) +-- We rely on directories changing mtime when entries are added or removed +testDirChangeSanity :: Int -> Assertion +testDirChangeSanity mtimeChange = + withTempDirectory silent "." "dir-mtime-" $ \dir -> do + + expectMTimeChange dir "file add" $ + IO.writeFile (dir "file") "content" + + expectMTimeSame dir "file content change" $ + IO.writeFile (dir "file") "new content" + + expectMTimeChange dir "file del" $ + IO.removeFile (dir "file") + + expectMTimeChange dir "subdir add" $ + IO.createDirectory (dir "dir") + + expectMTimeSame dir "subdir file add" $ + IO.writeFile (dir "dir" "file") "content" + + expectMTimeChange dir "subdir file move in" $ + IO.renameFile (dir "dir" "file") (dir "file") + + expectMTimeChange dir "subdir file move out" $ + IO.renameFile (dir "file") (dir "dir" "file") + + expectMTimeSame dir "subdir dir add" $ + IO.createDirectory (dir "dir" "subdir") + + expectMTimeChange dir "subdir dir move in" $ + IO.renameDirectory (dir "dir" "subdir") (dir "subdir") + + expectMTimeChange dir "subdir dir move out" $ + IO.renameDirectory (dir "subdir") (dir "dir" "subdir") + + where + expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO () + -> Assertion + + expectMTimeChange dir descr action = do + t <- getModTime dir + threadDelay mtimeChange + action + t' <- getModTime dir + assertBool ("expected dir mtime change on " ++ descr) (t' > t) + + expectMTimeSame dir descr action = do + t <- getModTime dir + threadDelay mtimeChange + action + t' <- getModTime dir + assertBool ("expected same dir mtime on " ++ descr) (t' == t) + + +-- Now for the FileMonitor tests proper... + -- first run, where we don't even call updateMonitor testNoMonitorCache :: Assertion testNoMonitorCache = @@ -327,6 +387,34 @@ touch' root "a" reason <- expectMonitorChanged root monitor () reason @?= MonitoredFileChanged "a" + +-- Monitoring the same file with two different kinds of monitor should work +-- both should be kept, and both checked for changes. +-- We had a bug where only one monitor kind was kept per file. +-- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178 +testMultipleMonitorKinds :: Int -> Assertion +testMultipleMonitorKinds mtimeChange = + withFileMonitor $ \root monitor -> do + touchFile root "a" + updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () () + (res, files) <- expectMonitorUnchanged root monitor () + res @?= () + files @?= [monitorFile "a", monitorFileHashed "a"] + threadDelay mtimeChange + touchFile root "a" -- not changing content, just mtime + reason <- expectMonitorChanged root monitor () + reason @?= MonitoredFileChanged "a" + + createDir root "dir" + updateMonitor root monitor [monitorDirectory "dir", + monitorDirectoryExistence "dir"] () () + (res2, files2) <- expectMonitorUnchanged root monitor () + res2 @?= () + files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"] + threadDelay mtimeChange + touchFile root ("dir" "a") -- changing dir mtime, not existence + reason2 <- expectMonitorChanged root monitor () + reason2 @?= MonitoredFileChanged "dir" ------------------ diff --git a/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs b/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs @@ -0,0 +1,60 @@ +module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where + +import Distribution.Text +import Data.Time +import Data.Time.Clock.POSIX + +import Distribution.Client.IndexUtils.Timestamp + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = + [ testProperty "Timestamp1" prop_timestamp1 + , testProperty "Timestamp2" prop_timestamp2 + , testProperty "Timestamp3" prop_timestamp3 + , testProperty "Timestamp4" prop_timestamp4 + , testProperty "Timestamp5" prop_timestamp5 + ] + +-- test unixtime format parsing +prop_timestamp1 :: Int -> Bool +prop_timestamp1 t0 = Just t == simpleParse ('@':show t0) + where + t = toEnum t0 :: Timestamp + +-- test display/simpleParse roundtrip +prop_timestamp2 :: Int -> Bool +prop_timestamp2 t0 + | t /= nullTimestamp = simpleParse (display t) == Just t + | otherwise = display t == "" + where + t = toEnum t0 :: Timestamp + +-- test display against reference impl +prop_timestamp3 :: Int -> Bool +prop_timestamp3 t0 + | t /= nullTimestamp = refDisp t == display t + | otherwise = display t == "" + where + t = toEnum t0 :: Timestamp + + refDisp = maybe undefined (formatTime undefined "%FT%TZ") + . timestampToUTCTime + +-- test utcTimeToTimestamp/timestampToUTCTime roundtrip +prop_timestamp4 :: Int -> Bool +prop_timestamp4 t0 + | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t + | otherwise = timestampToUTCTime t == Nothing + where + t = toEnum t0 :: Timestamp + +prop_timestamp5 :: Int -> Bool +prop_timestamp5 t0 + | t /= nullTimestamp = timestampToUTCTime t == Just ut + | otherwise = timestampToUTCTime t == Nothing + where + t = toEnum t0 :: Timestamp + ut = posixSecondsToUTCTime (fromIntegral t0) diff --git a/tests/UnitTests/Distribution/Client/InstallPlan.hs b/tests/UnitTests/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE ConstraintKinds #-} +module UnitTests.Distribution.Client.InstallPlan (tests) where + +import Distribution.Package +import Distribution.Version +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageFixedDeps +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Client.Types +import Distribution.Client.JobControl + +import Data.Graph +import Data.Array hiding (index) +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) +import Data.IORef +import Control.Monad +import Control.Concurrent (threadDelay) +import System.Random +import Test.QuickCheck + +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: [TestTree] +tests = + [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder + , testProperty "executionOrder" prop_executionOrder + , testProperty "execute serial" prop_execute_serial + , testProperty "execute parallel" prop_execute_parallel + , testProperty "execute/executionOrder" prop_execute_vs_executionOrder + ] + +prop_reverseTopologicalOrder :: TestInstallPlan -> Bool +prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) = + isReverseTopologicalOrder + graph + (map (toVertex . installedUnitId) + (InstallPlan.reverseTopologicalOrder plan)) + +-- | @executionOrder@ is in reverse topological order +prop_executionOrder :: TestInstallPlan -> Bool +prop_executionOrder (TestInstallPlan plan graph toVertex _) = + isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + where + pkgids = map installedUnitId (InstallPlan.executionOrder plan) + +-- | @execute@ is in reverse topological order +prop_execute_serial :: TestInstallPlan -> Property +prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) = + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + +prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property +prop_execute_parallel (Positive (Small maxJobLimit)) + tplan@(TestInstallPlan plan graph toVertex _) = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do + delay <- randomRIO (0,1000) + threadDelay delay + return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + +-- | return the packages that are visited by execute, in order. +executeTestInstallPlan :: JobControl IO (UnitId, Either () ()) + -> TestInstallPlan + -> (TestPkg -> IO ()) + -> IO [UnitId] +executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do + resultsRef <- newIORef [] + _ <- InstallPlan.execute jobCtl False (const ()) + plan $ \(ReadyPackage pkg) -> do + visit pkg + atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ()) + return (Right ()) + fmap reverse (readIORef resultsRef) + +-- | @execute@ visits the packages in the same order as @executionOrder@ +prop_execute_vs_executionOrder :: TestInstallPlan -> Property +prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) = + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + let pkgids' = map installedUnitId (InstallPlan.executionOrder plan) + return (pkgids == pkgids') + + +-------------------------- +-- Property helper utils +-- + +-- | A graph topological ordering is a linear ordering of its vertices such +-- that for every directed edge uv from vertex u to vertex v, u comes before v +-- in the ordering. +-- +-- A reverse topological ordering is the swapped: for every directed edge uv +-- from vertex u to vertex v, v comes before u in the ordering. +-- +isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool +isReverseTopologicalOrder g vs = + and [ ixs ! u > ixs ! v + | let ixs = array (bounds g) (zip vs [0::Int ..]) + , (u,v) <- edges g ] + +isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool +isReversePartialTopologicalOrder g vs = + and [ case (ixs ! u, ixs ! v) of + (Just ixu, Just ixv) -> ixu > ixv + _ -> True + | let ixs = array (bounds g) + (zip (range (bounds g)) (repeat Nothing) ++ + zip vs (map Just [0::Int ..])) + , (u,v) <- edges g ] + +allConfiguredPackages :: HasUnitId srcpkg + => GenericInstallPlan ipkg srcpkg -> Set UnitId +allConfiguredPackages plan = + Set.fromList + [ installedUnitId pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan ] + + +-------------------- +-- Test generators +-- + +data TestInstallPlan = TestInstallPlan + (GenericInstallPlan TestPkg TestPkg) + Graph + (UnitId -> Vertex) + (Vertex -> UnitId) + +instance Show TestInstallPlan where + show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan + +data TestPkg = TestPkg PackageId UnitId [UnitId] + deriving (Eq, Show) + +instance IsNode TestPkg where + type Key TestPkg = UnitId + nodeKey (TestPkg _ ipkgid _) = ipkgid + nodeNeighbors (TestPkg _ _ deps) = deps + + +instance Package TestPkg where + packageId (TestPkg pkgid _ _) = pkgid + +instance HasUnitId TestPkg where + installedUnitId (TestPkg _ ipkgid _) = ipkgid + +instance PackageFixedDeps TestPkg where + depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps + +instance PackageInstalled TestPkg where + installedDepends (TestPkg _ _ deps) = deps + +instance Arbitrary TestInstallPlan where + arbitrary = arbitraryTestInstallPlan + +arbitraryTestInstallPlan :: Gen TestInstallPlan +arbitraryTestInstallPlan = do + graph <- arbitraryAcyclicGraph + (choose (2,5)) + (choose (1,5)) + 0.3 + + plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph + + let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ] + fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ] + toVertex = (toVertexMap Map.!) + fromVertex = (fromVertexMap Map.!) + + return (TestInstallPlan plan graph toVertex fromVertex) + where + mkTestPkg pkgv depvs = + return (TestPkg pkgid ipkgid deps) + where + pkgid = mkPkgId pkgv + ipkgid = mkUnitIdV pkgv + deps = map mkUnitIdV depvs + mkUnitIdV = mkUnitId . show + mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v)) + (mkVersion [1]) + + +-- | Generate a random 'InstallPlan' following the structure of an existing +-- 'Graph'. +-- +-- It takes generators for installed and source packages and the chance that +-- each package is installed (for those packages with no prerequisites). +-- +arbitraryInstallPlan :: (IsUnit ipkg, + IsUnit srcpkg) + => (Vertex -> [Vertex] -> Gen ipkg) + -> (Vertex -> [Vertex] -> Gen srcpkg) + -> Float + -> Graph + -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) +arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do + + (ipkgvs, srcpkgvs) <- + fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) + . partition snd) $ + sequence + [ do isipkg <- if isRoot then pick ipkgProportion + else return False + return (v, isipkg) + | (v,n) <- assocs (outdegree graph) + , let isRoot = n == 0 ] + + ipkgs <- sequence + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- sequence + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = Graph.fromDistinctList + (map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs) + return $ InstallPlan.new (IndependentGoals False) index + + +-- | Generate a random directed acyclic graph, based on the algorithm presented +-- here +-- +-- It generates a DAG based on ranks of nodes. Nodes in each rank can only +-- have edges to nodes in subsequent ranks. +-- +-- The generator is paramterised by a generator for the number of ranks and +-- the number of nodes within each rank. It is also paramterised by the +-- chance that each node in each rank will have an edge from each node in +-- each previous rank. Thus a higher chance will produce a more densely +-- connected graph. +-- +arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph +arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do + nranks <- genNRanks + rankSizes <- replicateM nranks genNPerRank + let rankStarts = scanl (+) 0 rankSizes + rankRanges = drop 1 (zip rankStarts (tail rankStarts)) + totalRange = sum rankSizes + rankEdges <- mapM (uncurry genRank) rankRanges + return $ buildG (0, totalRange-1) (concat rankEdges) + where + genRank :: Vertex -> Vertex -> Gen [Edge] + genRank rankStart rankEnd = + filterM (const (pick edgeChance)) + [ (i,j) + | i <- [0..rankStart-1] + , j <- [rankStart..rankEnd-1] + ] + +pick :: Float -> Gen Bool +pick chance = do + p <- choose (0,1) + return (p < chance) + + +-------------------------------- +-- Inspecting generated graphs +-- + +{- +-- Handy util for checking the generated graphs look sensible +writeDotFile :: FilePath -> Graph -> IO () +writeDotFile file = writeFile file . renderDotGraph + +renderDotGraph :: Graph -> String +renderDotGraph graph = + unlines ( + [header + ,graphDefaultAtribs + ,nodeDefaultAtribs + ,edgeDefaultAtribs] + ++ map renderNode (vertices graph) + ++ map renderEdge (edges graph) + ++ [footer] + ) + where + renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++ "\"];" + + renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" + + +header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String + +header = "digraph packages {" +footer = "}" + +graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" +nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" +edgeDefaultAtribs = "\tedge [fontsize=10];" +-} diff --git a/tests/UnitTests/Distribution/Client/JobControl.hs b/tests/UnitTests/Distribution/Client/JobControl.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/JobControl.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module UnitTests.Distribution.Client.JobControl (tests) where + +import Distribution.Client.JobControl + +import Data.List +import Data.Maybe +import Data.IORef +import Control.Monad +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, try, throwIO) +import Data.Typeable (Typeable) +import qualified Data.Set as Set + +import Test.Tasty +import Test.Tasty.QuickCheck hiding (collect) + + +tests :: [TestTree] +tests = + [ testGroup "serial" + [ testProperty "submit batch" prop_submit_serial + , testProperty "submit batch" prop_remaining_serial + , testProperty "submit interleaved" prop_interleaved_serial + , testProperty "concurrent jobs" prop_concurrent_serial + , testProperty "cancel" prop_cancel_serial + , testProperty "exceptions" prop_exception_serial + ] + , testGroup "parallel" + [ testProperty "submit batch" prop_submit_parallel + , testProperty "submit batch" prop_remaining_parallel + , testProperty "submit interleaved" prop_interleaved_parallel + , testProperty "concurrent jobs" prop_concurrent_parallel + , testProperty "cancel" prop_cancel_parallel + , testProperty "exceptions" prop_exception_parallel + ] + ] + + +prop_submit_serial :: [Int] -> Property +prop_submit_serial xs = + ioProperty $ do + jobCtl <- newSerialJobControl + prop_submit jobCtl xs + +prop_submit_parallel :: Positive (Small Int) -> [Int] -> Property +prop_submit_parallel (Positive (Small maxJobLimit)) xs = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + prop_submit jobCtl xs + +prop_remaining_serial :: [Int] -> Property +prop_remaining_serial xs = + ioProperty $ do + jobCtl <- newSerialJobControl + prop_remaining jobCtl xs + +prop_remaining_parallel :: Positive (Small Int) -> [Int] -> Property +prop_remaining_parallel (Positive (Small maxJobLimit)) xs = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + prop_remaining jobCtl xs + +prop_interleaved_serial :: [Int] -> Property +prop_interleaved_serial xs = + ioProperty $ do + jobCtl <- newSerialJobControl + prop_submit_interleaved jobCtl xs + +prop_interleaved_parallel :: Positive (Small Int) -> [Int] -> Property +prop_interleaved_parallel (Positive (Small maxJobLimit)) xs = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + prop_submit_interleaved jobCtl xs + +prop_submit :: JobControl IO Int -> [Int] -> IO Bool +prop_submit jobCtl xs = do + mapM_ (\x -> spawnJob jobCtl (return x)) xs + xs' <- mapM (\_ -> collectJob jobCtl) xs + return (sort xs == sort xs') + +prop_remaining :: JobControl IO Int -> [Int] -> IO Bool +prop_remaining jobCtl xs = do + mapM_ (\x -> spawnJob jobCtl (return x)) xs + xs' <- collectRemainingJobs jobCtl + return (sort xs == sort xs') + +collectRemainingJobs :: Monad m => JobControl m a -> m [a] +collectRemainingJobs jobCtl = go [] + where + go xs = do + remaining <- remainingJobs jobCtl + if remaining + then do x <- collectJob jobCtl + go (x:xs) + else return xs + +prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool +prop_submit_interleaved jobCtl xs = do + xs' <- sequence + [ spawn >> collect + | let spawns = map (\x -> spawnJob jobCtl (return (Just x))) xs + ++ repeat (return ()) + collects = replicate 5 (return Nothing) + ++ map (\_ -> collectJob jobCtl) xs + , (spawn, collect) <- zip spawns collects + ] + return (sort xs == sort (catMaybes xs')) + +prop_concurrent_serial :: NonNegative (Small Int) -> Property +prop_concurrent_serial (NonNegative (Small ntasks)) = + ioProperty $ do + jobCtl <- newSerialJobControl + countRef <- newIORef (0 :: Int) + replicateM_ ntasks (spawnJob jobCtl (task countRef)) + counts <- replicateM ntasks (collectJob jobCtl) + return $ length counts == ntasks + && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts + where + task countRef = do + n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) + threadDelay 100 + n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) + return (n0, n1) + +prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property +prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + countRef <- newIORef (0 :: Int) + replicateM_ ntasks (spawnJob jobCtl (task countRef)) + counts <- replicateM ntasks (collectJob jobCtl) + return $ length counts == ntasks + && all (\(n0, n1) -> n0 >= 0 && n0 < maxJobLimit + && n1 > 0 && n1 <= maxJobLimit) counts + -- we do hit the concurrency limit (in the right circumstances) + && if ntasks >= maxJobLimit*2 -- give us enough of a margin + then any (\(_,n1) -> n1 == maxJobLimit) counts + else True + where + task countRef = do + n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) + threadDelay 100 + n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) + return (n0, n1) + +prop_cancel_serial :: [Int] -> [Int] -> Property +prop_cancel_serial xs ys = + ioProperty $ do + jobCtl <- newSerialJobControl + mapM_ (\x -> spawnJob jobCtl (return x)) (xs++ys) + xs' <- mapM (\_ -> collectJob jobCtl) xs + cancelJobs jobCtl + ys' <- collectRemainingJobs jobCtl + return (sort xs == sort xs' && null ys') + +prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property +prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + mapM_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs++ys) + xs' <- mapM (\_ -> collectJob jobCtl) xs + cancelJobs jobCtl + ys' <- collectRemainingJobs jobCtl + return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys) + +data TestException = TestException Int + deriving (Typeable, Show) + +instance Exception TestException + +prop_exception_serial :: [Either Int Int] -> Property +prop_exception_serial xs = + ioProperty $ do + jobCtl <- newSerialJobControl + prop_exception jobCtl xs + +prop_exception_parallel :: Positive (Small Int) -> [Either Int Int] -> Property +prop_exception_parallel (Positive (Small maxJobLimit)) xs = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + prop_exception jobCtl xs + +prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool +prop_exception jobCtl xs = do + mapM_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs + xs' <- replicateM (length xs) $ do + mx <- try (collectJob jobCtl) + return $ case mx of + Left (TestException n) -> Left n + Right n -> Right n + return (sort xs == sort xs') + diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -31,6 +31,11 @@ import Distribution.Utils.NubList import Network.URI +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.Settings + import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy @@ -72,7 +77,7 @@ where usingGhc76orOlder = case buildCompilerId of - CompilerId GHC v -> v < Version [7,7] [] + CompilerId GHC v -> v < mkVersion [7,7] _ -> False @@ -91,8 +96,11 @@ prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool -prop_roundtrip_legacytypes_all = +prop_roundtrip_legacytypes_all config = roundtrip_legacytypes + config { + projectConfigProvenance = mempty + } prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool prop_roundtrip_legacytypes_packages config = @@ -100,6 +108,7 @@ config { projectConfigBuildOnly = mempty, projectConfigShared = mempty, + projectConfigProvenance = mempty, projectConfigLocalPackages = mempty, projectConfigSpecificPackage = mempty } @@ -136,7 +145,7 @@ . showLegacyProjectConfig . convertToLegacyProjectConfig) config of - ParseOk _ x -> x == config + ParseOk _ x -> x == config { projectConfigProvenance = mempty } _ -> False @@ -190,12 +199,13 @@ hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared hackProjectConfigShared config = config { + projectConfigProjectFile = mempty, -- not present within project files projectConfigConstraints = --TODO: [required eventually] parse ambiguity in constraint -- "pkgname -any" as either any version or disabled flag "any". - let ambiguous ((UserConstraintFlags _pkg flags), _) = - (not . null) [ () | (FlagName name, False) <- flags - , "any" `isPrefixOf` name ] + let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = + (not . null) [ () | (name, False) <- flags + , "any" `isPrefixOf` unFlagName name ] ambiguous _ = False in filter (not . ambiguous) (projectConfigConstraints config) } @@ -240,19 +250,21 @@ <*> (map getPackageLocationString <$> arbitrary) <*> shortListOf 3 arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary <*> (MapMappend . fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary) -- package entries with no content are equivalent to -- the entry not existing at all, so exclude empty - shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) = + shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) = [ ProjectConfig x0' x1' x2' x3' - x4' x5' x6' (MapMappend (fmap getNonMEmpty x7')) - | ((x0', x1', x2', x3'), (x4', x5', x6', x7')) + x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8')) + | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8')) <- shrink ((x0, x1, x2, x3), - (x4, x5, x6, fmap NonMEmpty (getMapMappend x7))) + (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8))) ] newtype PackageLocationString @@ -295,11 +307,10 @@ <*> arbitrary <*> arbitraryNumJobs <*> arbitrary - <*> arbitrary -- 12 - <*> (fmap getShortToken <$> arbitrary) <*> arbitrary + <*> arbitrary <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) -- 16 + <*> arbitrary <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary) where @@ -308,19 +319,19 @@ shrink (ProjectConfigBuildOnly x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 x10 x11 x12 x13 x14 x15 - x16 x17) = + x16) = [ ProjectConfigBuildOnly x00' x01' x02' x03' x04' x05' x06' x07' x08' (postShrink_NumJobs x09') - x10' x11' x12 x13' x14 - x15 x16 x17 + x10' x11' x12' x13 x14' + x15 x16 | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), - (x10', x11', x13')) + (x10', x11', x12', x14')) <- shrink ((x00, x01, x02, x03, x04), (x05, x06, x07, x08, preShrink_NumJobs x09), - (x10, x11, x13)) + (x10, x11, x12, x14)) ] where preShrink_NumJobs = fmap (fmap Positive) @@ -329,17 +340,23 @@ instance Arbitrary ProjectConfigShared where arbitrary = ProjectConfigShared - <$> arbitrary -- 4 + <$> arbitraryFlag arbitraryShortToken <*> arbitraryFlag arbitraryShortToken + <*> arbitrary <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitrary <*> (toNubList <$> listOf arbitraryShortToken) + <*> arbitrary <*> arbitraryConstraints <*> shortListOf 2 arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = @@ -348,18 +365,24 @@ shrink (ProjectConfigShared x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 - x10 x11 x12 x13) = + x10 x11 x12 x13 x14 + x15 x16 x17 x18 x19 + x20) = [ ProjectConfigShared - x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04' - x05' (postShrink_Constraints x06') x07' x08' x09' - x10' x11' x12' x13' + x00' x01' x02' (fmap getNonEmpty x03') (fmap getNonEmpty x04') + x05' x06' x07' x08' (postShrink_Constraints x09') + x10' x11' x12' x13' x14' x15' x16' x17' x18' x19' x20' | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), - (x10', x11', x12', x13')) + (x10', x11', x12', x13', x14'), + (x15', x16', x17', x18', x19'), + x20') <- shrink - ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04), - (x05, preShrink_Constraints x06, x07, x08, x09), - (x10, x11, x12, x13)) + ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), + (x05, x06, x07, x08, preShrink_Constraints x09), + (x10, x11, x12, x13, x14), + (x15, x16, x17, x18, x19), + x20) ] where preShrink_Constraints = map fst @@ -369,6 +392,9 @@ projectConfigConstraintSource = ConstraintSourceProjectConfig "TODO" +instance Arbitrary ProjectConfigProvenance where + arbitrary = elements [Implicit, Explicit "cabal.project"] + instance Arbitrary PackageConfig where arbitrary = PackageConfig @@ -399,6 +425,7 @@ <*> arbitrary <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryFlag arbitraryShortToken @@ -418,7 +445,7 @@ x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 - x30 x31 x32 x33 x34 + x30 x31 x32 x33 x33_1 x34 x35 x36 x37 x38 x39 x40) = [ PackageConfig @@ -432,7 +459,7 @@ x19' x20' x21' x22' x23' x24' x25' x26' x27' x28' x29' - x30' x31' x32' x33' x34' + x30' x31' x32' x33' x33_1' x34' x35' x36' (fmap getNonEmpty x37') x38' (fmap getNonEmpty x39') x40' @@ -442,7 +469,7 @@ (x15', x16', x17', x18', x19')), ((x20', x21', x22', x23', x24'), (x25', x26', x27', x28', x29'), - (x30', x31', x32', x33', x34'), + (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x39'), (x40'))) <- shrink @@ -455,7 +482,7 @@ x19)), ((x20, x21, x22, x23, x24), (x25, x26, x27, x28, x29), - (x30, x31, x32, x33, x34), + (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39), (x40))) ] @@ -482,7 +509,7 @@ <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary)) - `suchThat` (/= emptySourceRepo) + `suchThat` (/= emptySourceRepo RepoThis) shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) = [ repo @@ -499,14 +526,9 @@ (fmap getShortToken x4') (fmap getShortToken x5') (fmap getShortToken x6') - , repo /= emptySourceRepo + , repo /= emptySourceRepo RepoThis ] -emptySourceRepo :: SourceRepo -emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing - Nothing Nothing Nothing - - instance Arbitrary RepoType where arbitrary = elements knownRepoTypes @@ -527,7 +549,7 @@ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary -- 14 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 instance Arbitrary PackageDB where arbitrary = oneof [ pure GlobalPackageDB @@ -549,21 +571,36 @@ shortListOf1 5 (oneof [ choose ('0', '9') , choose ('a', 'f') ]) +instance Arbitrary UserConstraintScope where + arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary + , UserAnySetupQualifier <$> arbitrary + , UserAnyQualifier <$> arbitrary + ] + +instance Arbitrary UserQualifier where + arbitrary = oneof [ pure UserQualToplevel + , UserQualSetup <$> arbitrary + + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- , UserQualExe <$> arbitrary <*> arbitrary + ] + instance Arbitrary UserConstraint where - arbitrary = - oneof - [ UserConstraintVersion <$> arbitrary <*> arbitrary - , UserConstraintInstalled <$> arbitrary - , UserConstraintSource <$> arbitrary - , UserConstraintFlags <$> arbitrary <*> shortListOf1 3 arbitrary - , UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary) - ] + arbitrary = UserConstraint <$> arbitrary <*> arbitrary +instance Arbitrary PackageProperty where + arbitrary = oneof [ PackagePropertyVersion <$> arbitrary + , pure PackagePropertyInstalled + , pure PackagePropertySource + , PackagePropertyFlags <$> shortListOf1 3 arbitrary + , PackagePropertyStanzas . (\x->[x]) <$> arbitrary + ] + instance Arbitrary OptionalStanza where arbitrary = elements [minBound..maxBound] instance Arbitrary FlagName where - arbitrary = FlagName <$> flagident + arbitrary = mkFlagName <$> flagident where flagident = lowercase <$> shortListOf1 5 (elements flagChars) `suchThat` (("-" /=) . take 1) @@ -572,15 +609,33 @@ instance Arbitrary PreSolver where arbitrary = elements [minBound..maxBound] +instance Arbitrary ReorderGoals where + arbitrary = ReorderGoals <$> arbitrary + +instance Arbitrary CountConflicts where + arbitrary = CountConflicts <$> arbitrary + +instance Arbitrary StrongFlags where + arbitrary = StrongFlags <$> arbitrary + +instance Arbitrary AllowBootLibInstalls where + arbitrary = AllowBootLibInstalls <$> arbitrary + instance Arbitrary AllowNewer where - arbitrary = oneof [ pure AllowNewerNone - , AllowNewerSome <$> shortListOf1 3 arbitrary - , pure AllowNewerAll + arbitrary = AllowNewer <$> arbitrary + +instance Arbitrary AllowOlder where + arbitrary = AllowOlder <$> arbitrary + +instance Arbitrary RelaxDeps where + arbitrary = oneof [ pure RelaxDepsNone + , RelaxDepsSome <$> shortListOf1 3 arbitrary + , pure RelaxDepsAll ] -instance Arbitrary AllowNewerDep where - arbitrary = oneof [ AllowNewerDep <$> arbitrary - , AllowNewerDepScoped <$> arbitrary <*> arbitrary +instance Arbitrary RelaxedDep where + arbitrary = oneof [ RelaxedDep <$> arbitrary + , RelaxedDepScoped <$> arbitrary <*> arbitrary ] instance Arbitrary ProfDetailLevel where diff --git a/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs b/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs --- a/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs +++ b/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs @@ -5,7 +5,7 @@ import Distribution.Simple.Utils (withTempDirectory) import Distribution.Verbosity -import Distribution.Client.Compat.Time +import Distribution.Compat.Time import Distribution.Client.Sandbox.Timestamp import Test.Tasty @@ -44,7 +44,7 @@ withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir "timestamp-record" writeFile fileName fileContent - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" expected tRec @@ -58,6 +58,6 @@ withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir "timestamp-record" writeTimestampFile fileName timestampRecord - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" timestampRecord tRec diff --git a/tests/UnitTests/Distribution/Client/Store.hs b/tests/UnitTests/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/Store.hs @@ -0,0 +1,181 @@ +module UnitTests.Distribution.Client.Store (tests) where + +--import Control.Monad +--import Control.Concurrent (forkIO, threadDelay) +--import Control.Concurrent.MVar +import qualified Data.Set as Set +import System.FilePath +import System.Directory +--import System.Random + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) +import Distribution.Version (mkVersion) +import Distribution.Verbosity (Verbosity, silent) +import Distribution.Simple.Utils (withTempDirectory) + +import Distribution.Client.Store +import Distribution.Client.RebuildMonad + +import Test.Tasty +import Test.Tasty.HUnit + + +tests :: [TestTree] +tests = + [ testCase "list content empty" testListEmpty + , testCase "install serial" testInstallSerial +--, testCase "install parallel" testInstallParallel + --TODO: figure out some way to do a parallel test, see issue below + ] + + +testListEmpty :: Assertion +testListEmpty = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + + assertStoreEntryExists storeDirLayout compid unitid False + assertStoreContent tmp storeDirLayout compid Set.empty + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid = mkUnitId "foo-1.0-xyz" + + +testInstallSerial :: Assertion +testInstallSerial = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + copyFiles file content dir = do + -- we copy into a prefix inside the tmp dir and return the prefix + let destprefix = dir "prefix" + createDirectory destprefix + writeFile (destprefix file) content + return destprefix + + assertNewStoreEntry tmp storeDirLayout compid unitid1 + (copyFiles "file1" "content-foo") (return ()) + UseNewStoreEntry + + assertNewStoreEntry tmp storeDirLayout compid unitid1 + (copyFiles "file1" "content-foo") (return ()) + UseExistingStoreEntry + + assertNewStoreEntry tmp storeDirLayout compid unitid2 + (copyFiles "file2" "content-bar") (return ()) + UseNewStoreEntry + + let pkgDir :: UnitId -> FilePath + pkgDir = storePackageDirectory storeDirLayout compid + assertFileEqual (pkgDir unitid1 "file1") "content-foo" + assertFileEqual (pkgDir unitid2 "file2") "content-bar" + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid1 = mkUnitId "foo-1.0-xyz" + unitid2 = mkUnitId "bar-2.0-xyz" + + +{- +-- unfortunately a parallel test like the one below is thwarted by the normal +-- process-internal file locking. If that locking were not in place then we +-- ought to get the blocking behaviour, but due to the normal Handle locking +-- it just fails instead. + +testInstallParallel :: Assertion +testInstallParallel = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + + sync1 <- newEmptyMVar + sync2 <- newEmptyMVar + outv <- newEmptyMVar + regv <- newMVar (0 :: Int) + + sequence_ + [ do forkIO $ do + let copyFiles dir = do + delay <- randomRIO (1,100000) + writeFile (dir "file") (show n) + putMVar sync1 () + readMVar sync2 + threadDelay delay + register = do + modifyMVar_ regv (return . (+1)) + threadDelay 200000 + o <- newStoreEntry verbosity storeDirLayout + compid unitid + copyFiles register + putMVar outv (n, o) + | n <- [0..9 :: Int] ] + + replicateM_ 10 (takeMVar sync1) + -- all threads are in the copyFiles action concurrently, release them: + putMVar sync2 () + + outcomes <- replicateM 10 (takeMVar outv) + regcount <- readMVar regv + let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ] + + assertEqual "num registrations" 1 regcount + assertEqual "num registrations" 1 regcount' + + assertStoreContent tmp storeDirLayout compid (Set.singleton unitid) + + let pkgDir :: UnitId -> FilePath + pkgDir = storePackageDirectory storeDirLayout compid + case [ n | (n, UseNewStoreEntry) <- outcomes ] of + [n] -> assertFileEqual (pkgDir unitid "file") (show n) + _ -> assertFailure "impossible" + + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid = mkUnitId "foo-1.0-xyz" +-} + +------------- +-- Utils + +assertNewStoreEntry :: FilePath -> StoreDirLayout + -> CompilerId -> UnitId + -> (FilePath -> IO FilePath) -> IO () + -> NewStoreEntryOutcome + -> Assertion +assertNewStoreEntry tmp storeDirLayout compid unitid + copyFiles register expectedOutcome = do + entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid + outcome <- newStoreEntry verbosity storeDirLayout + compid unitid + copyFiles register + assertEqual "newStoreEntry outcome" expectedOutcome outcome + assertStoreEntryExists storeDirLayout compid unitid True + let expected = Set.insert unitid entries + assertStoreContent tmp storeDirLayout compid expected + + +assertStoreEntryExists :: StoreDirLayout + -> CompilerId -> UnitId -> Bool + -> Assertion +assertStoreEntryExists storeDirLayout compid unitid expected = do + actual <- doesStoreEntryExist storeDirLayout compid unitid + assertEqual "store entry exists" expected actual + + +assertStoreContent :: FilePath -> StoreDirLayout + -> CompilerId -> Set.Set UnitId + -> Assertion +assertStoreContent tmp storeDirLayout compid expected = do + actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid + assertEqual "store content" actual expected + + +assertFileEqual :: FilePath -> String -> Assertion +assertFileEqual path expected = do + exists <- doesFileExist path + assertBool ("file does not exist:\n" ++ path) exists + actual <- readFile path + assertEqual ("file content for:\n" ++ path) expected actual + + +verbosity :: Verbosity +verbosity = silent + 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 @@ -2,57 +2,105 @@ tests ) where -import Distribution.Client.Targets (UserConstraint (..), readUserConstraint) -import Distribution.Compat.ReadP (ReadP, readP_to_S) -import Distribution.Package (PackageName (..)) +import Distribution.Client.Targets (UserQualifier(..) + ,UserConstraintScope(..) + ,UserConstraint(..), readUserConstraint) +import Distribution.Compat.ReadP (readP_to_S) +import Distribution.Package (mkPackageName) +import Distribution.PackageDescription (mkFlagName) +import Distribution.Version (anyVersion, thisVersion, mkVersion) import Distribution.ParseUtils (parseCommaList) import Distribution.Text (parse) +import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) +import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) + import Test.Tasty import Test.Tasty.HUnit import Data.Char (isSpace) +import Data.List (intercalate) -tests :: [TestTree] -tests = [ testCase "readUserConstraint" readUserConstraintTest - , testCase "parseUserConstraint" parseUserConstraintTest - , testCase "readUserConstraints" readUserConstraintsTest - ] +-- Helper function: makes a test group by mapping each element +-- of a list to a test case. +makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree +makeGroup name f xs = testGroup name $ + zipWith testCase (map show [0 :: Integer ..]) (map f xs) -readUserConstraintTest :: Assertion -readUserConstraintTest = - assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual +tests :: [TestTree] +tests = + [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest) + exampleConstraints + + , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest) + exampleConstraints + + , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest) + [-- First example only. + (head exampleStrs, take 1 exampleUcs), + -- All examples separated by commas. + (intercalate ", " exampleStrs, exampleUcs)] + ] where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + (exampleStrs, exampleUcs) = unzip exampleConstraints - expected = UserConstraintInstalled (PackageName pkgName) - actual = let (Right r) = readUserConstraint constr in r +exampleConstraints :: [(String, UserConstraint)] +exampleConstraints = + [ ("template-haskell installed", + UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) + PackagePropertyInstalled) + + , ("bytestring -any", + UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) + (PackagePropertyVersion anyVersion)) -parseUserConstraintTest :: Assertion -parseUserConstraintTest = - assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual - where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + , ("any.directory test", + UserConstraint (UserAnyQualifier (pn "directory")) + (PackagePropertyStanzas [TestStanzas])) - expected = [UserConstraintInstalled (PackageName pkgName)] - actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr - , all isSpace ys] + , ("setup.Cabal installed", + UserConstraint (UserAnySetupQualifier (pn "Cabal")) + PackagePropertyInstalled) - parseUserConstraint :: ReadP r UserConstraint - parseUserConstraint = parse + , ("process:setup.bytestring ==5.2", + UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) + (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) + + , ("network:setup.containers +foo -bar baz", + UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) + (PackagePropertyFlags [(fn "foo", True), + (fn "bar", False), + (fn "baz", True)])) + + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- + -- , ("foo:happy:exe.template-haskell test", + -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell")) + -- (PackagePropertyStanzas [TestStanzas])) + ] + where + pn = mkPackageName + fn = mkFlagName -readUserConstraintsTest :: Assertion -readUserConstraintsTest = - assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual +readUserConstraintTest :: String -> UserConstraint -> Assertion +readUserConstraintTest str uc = + assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + expected = uc + actual = let Right r = readUserConstraint str in r - expected = [[UserConstraintInstalled (PackageName pkgName)]] - actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr +parseUserConstraintTest :: String -> UserConstraint -> Assertion +parseUserConstraintTest str uc = + assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual + where + expected = [uc] + actual = [ x | (x, ys) <- readP_to_S parse str , all isSpace ys] - parseUserConstraints :: ReadP r [UserConstraint] - parseUserConstraints = parseCommaList parse +readUserConstraintsTest :: String -> [UserConstraint] -> Assertion +readUserConstraintsTest str ucs = + assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual + where + expected = [ucs] + actual = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str + , all isSpace ys] diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -0,0 +1,688 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | DSL for testing the modular solver +module UnitTests.Distribution.Solver.Modular.DSL ( + ExampleDependency(..) + , Dependencies(..) + , ExTest(..) + , ExExe(..) + , ExConstraint(..) + , ExPreference(..) + , ExampleDb + , ExampleVersionRange + , ExamplePkgVersion + , ExamplePkgName + , ExampleFlagName + , ExFlag(..) + , ExampleAvailable(..) + , ExampleInstalled(..) + , ExampleQualifier(..) + , ExampleVar(..) + , EnableAllTests(..) + , exAv + , exInst + , exFlagged + , exResolve + , extractInstallPlan + , declareFlags + , withSetupDeps + , withTest + , withTests + , withExe + , withExes + , runProgress + , mkVersionRange + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +-- base +import Data.Either (partitionEithers) +import Data.List (elemIndex) +import Data.Ord (comparing) +import qualified Data.Map as Map + +-- Cabal +import qualified Distribution.Compiler as C +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (License(..)) +import qualified Distribution.ModuleName as Module +import qualified Distribution.Package as C + hiding (HasUnitId(..)) +import qualified Distribution.Types.LegacyExeDependency as C +import qualified Distribution.Types.PkgconfigDependency as C +import qualified Distribution.Types.UnqualComponentName as C +import qualified Distribution.Types.CondTree as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Check as C +import qualified Distribution.Simple.PackageIndex as C.PackageIndex +import Distribution.Simple.Setup (BooleanFlag(..)) +import qualified Distribution.System as C +import Distribution.Text (display) +import qualified Distribution.Version as C +import Language.Haskell.Extension (Extension(..), Language(..)) + +-- cabal-install +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import Distribution.Client.Types +import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan + +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackagePath as P +import qualified Distribution.Solver.Types.PkgConfigDb as PC +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Variable + +{------------------------------------------------------------------------------- + Example package database DSL + + In order to be able to set simple examples up quickly, we define a very + simple version of the package database here explicitly designed for use in + tests. + + The design of `ExampleDb` takes the perspective of the solver, not the + perspective of the package DB. This makes it easier to set up tests for + various parts of the solver, but makes the mapping somewhat awkward, because + it means we first map from "solver perspective" `ExampleDb` to the package + database format, and then the modular solver internally in `IndexConversion` + maps this back to the solver specific data structures. + + IMPLEMENTATION NOTES + -------------------- + + TODO: Perhaps these should be made comments of the corresponding data type + definitions. For now these are just my own conclusions and may be wrong. + + * The difference between `GenericPackageDescription` and `PackageDescription` + is that `PackageDescription` describes a particular _configuration_ of a + package (for instance, see documentation for `checkPackage`). A + `GenericPackageDescription` can be turned into a `PackageDescription` in + two ways: + + a. `finalizePD` does the proper translation, by taking + into account the platform, available dependencies, etc. and picks a + flag assignment (or gives an error if no flag assignment can be found) + b. `flattenPackageDescription` ignores flag assignment and just joins all + components together. + + The slightly odd thing is that a `GenericPackageDescription` contains a + `PackageDescription` as a field; both of the above functions do the same + thing: they take the embedded `PackageDescription` as a basis for the result + value, but override `library`, `executables`, `testSuites`, `benchmarks` + and `buildDepends`. + * The `condTreeComponents` fields of a `CondTree` is a list of triples + `(condition, then-branch, else-branch)`, where the `else-branch` is + optional. +-------------------------------------------------------------------------------} + +type ExamplePkgName = String +type ExamplePkgVersion = Int +type ExamplePkgHash = String -- for example "installed" packages +type ExampleFlagName = String +type ExampleTestName = String +type ExampleExeName = String +type ExampleVersionRange = C.VersionRange + +data Dependencies = NotBuildable | Buildable [ExampleDependency] + deriving Show + +data ExampleDependency = + -- | Simple dependency on any version + ExAny ExamplePkgName + + -- | Simple dependency on a fixed version + | ExFix ExamplePkgName ExamplePkgVersion + + -- | Simple dependency on a range of versions, with an inclusive lower bound + -- and an exclusive upper bound. + | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion + + -- | Build-tools dependency + | ExBuildToolAny ExamplePkgName + + -- | Build-tools dependency on a fixed version + | ExBuildToolFix ExamplePkgName ExamplePkgVersion + + -- | Dependencies indexed by a flag + | ExFlagged ExampleFlagName Dependencies Dependencies + + -- | Dependency on a language extension + | ExExt Extension + + -- | Dependency on a language version + | ExLang Language + + -- | Dependency on a pkg-config package + | ExPkg (ExamplePkgName, ExamplePkgVersion) + deriving Show + +-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in +-- example source packages. +data ExFlag = ExFlag { + exFlagName :: ExampleFlagName + , exFlagDefault :: Bool + , exFlagType :: FlagType + } deriving Show + +data ExTest = ExTest ExampleTestName [ExampleDependency] + +data ExExe = ExExe ExampleExeName [ExampleDependency] + +exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] + -> ExampleDependency +exFlagged n t e = ExFlagged n (Buildable t) (Buildable e) + +data ExConstraint = + ExVersionConstraint ConstraintScope ExampleVersionRange + | ExFlagConstraint ConstraintScope ExampleFlagName Bool + +data ExPreference = + ExPkgPref ExamplePkgName ExampleVersionRange + | ExStanzaPref ExamplePkgName [OptionalStanza] + +data ExampleAvailable = ExAv { + exAvName :: ExamplePkgName + , exAvVersion :: ExamplePkgVersion + , exAvDeps :: ComponentDeps [ExampleDependency] + + -- Setting flags here is only necessary to override the default values of + -- the fields in C.Flag. + , exAvFlags :: [ExFlag] + } deriving Show + +data ExampleVar = + P ExampleQualifier ExamplePkgName + | F ExampleQualifier ExamplePkgName ExampleFlagName + | S ExampleQualifier ExamplePkgName OptionalStanza + +data ExampleQualifier = + None + | Indep Int + | Setup ExamplePkgName + | IndepSetup Int ExamplePkgName + +-- | Whether to enable tests in all packages in a test case. +newtype EnableAllTests = EnableAllTests Bool + deriving BooleanFlag + +-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', +-- given: +-- +-- 1. The name 'ExamplePkgName' of the available package, +-- 2. The version 'ExamplePkgVersion' available +-- 3. The list of dependency constraints 'ExampleDependency' +-- that this package has. 'ExampleDependency' provides +-- a number of pre-canned dependency types to look at. +-- +exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] + -> ExampleAvailable +exAv n v ds = ExAv { exAvName = n, exAvVersion = v + , exAvDeps = CD.fromLibraryDeps ds, exAvFlags = [] } + +-- | Override the default settings (e.g., manual vs. automatic) for a subset of +-- a package's flags. +declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable +declareFlags flags ex = ex { + exAvFlags = flags + } + +withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable +withSetupDeps ex setupDeps = ex { + exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps + } + +withTest :: ExampleAvailable -> ExTest -> ExampleAvailable +withTest ex test = withTests ex [test] + +withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable +withTests ex tests = + let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) + | ExTest name deps <- tests] + in ex { exAvDeps = exAvDeps ex <> testCDs } + +withExe :: ExampleAvailable -> ExExe -> ExampleAvailable +withExe ex exe = withExes ex [exe] + +withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable +withExes ex exes = + let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) + | ExExe name deps <- exes] + in ex { exAvDeps = exAvDeps ex <> exeCDs } + +-- | An installed package in 'ExampleDb'; construct me with 'exInst'. +data ExampleInstalled = ExInst { + exInstName :: ExamplePkgName + , exInstVersion :: ExamplePkgVersion + , exInstHash :: ExamplePkgHash + , exInstBuildAgainst :: [ExamplePkgHash] + } deriving Show + +-- | Constructs an example installed package given: +-- +-- 1. The name of the package 'ExamplePkgName', i.e., 'String' +-- 2. The version of the package 'ExamplePkgVersion', i.e., 'Int' +-- 3. The IPID for the package 'ExamplePkgHash', i.e., 'String' +-- (just some unique identifier for the package.) +-- 4. The 'ExampleInstalled' packages which this package was +-- compiled against.) +-- +exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash + -> [ExampleInstalled] -> ExampleInstalled +exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) + +-- | An example package database is a list of installed packages +-- 'ExampleInstalled' and available packages 'ExampleAvailable'. +-- Generally, you want to use 'exInst' and 'exAv' to construct +-- these packages. +type ExampleDb = [Either ExampleInstalled ExampleAvailable] + +type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a + +type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a + +exDbPkgs :: ExampleDb -> [ExamplePkgName] +exDbPkgs = map (either exInstName exAvName) + +exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage +exAvSrcPkg ex = + let pkgId = exAvPkgId ex + + flags :: [C.Flag] + flags = + let declaredFlags :: Map ExampleFlagName C.Flag + declaredFlags = + Map.fromListWith + (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) + [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] + + usedFlags :: Map ExampleFlagName C.Flag + usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] + where + names = concatMap extractFlags $ + CD.libraryDeps (exAvDeps ex) + ++ concatMap snd testSuites + ++ concatMap snd executables + in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: + Map.elems $ declaredFlags `Map.union` usedFlags + + testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] + executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] + setup = case CD.setupDeps (exAvDeps ex) of + [] -> Nothing + deps -> Just C.SetupBuildInfo { + C.setupDepends = mkSetupDeps deps, + C.defaultSetupDepends = False + } + package = SourcePackage { + packageInfoId = pkgId + , packageSource = LocalTarballPackage "<>" + , packageDescrOverride = Nothing + , packageDescription = C.GenericPackageDescription { + C.packageDescription = C.emptyPackageDescription { + C.package = pkgId + , C.setupBuildInfo = setup + , C.license = BSD3 + , C.buildType = if isNothing setup + then Just C.Simple + else Just C.Custom + , C.category = "category" + , C.maintainer = "maintainer" + , C.description = "description" + , C.synopsis = "synopsis" + , C.licenseFiles = ["LICENSE"] + , C.specVersionRaw = Left $ C.mkVersion [1,12] + } + , C.genPackageFlags = flags + , C.condLibrary = + let mkLib bi = mempty { C.libBuildInfo = bi } + in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $ + Buildable (CD.libraryDeps (exAvDeps ex)) + , C.condSubLibraries = [] + , C.condForeignLibs = [] + , C.condExecutables = + let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable + mkExe bi = mempty { C.buildInfo = bi } + in map (\(t, deps) -> (t, mkTree deps)) executables + , C.condTestSuites = + let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable + mkTest bi = mempty { C.testBuildInfo = bi } + in map (\(t, deps) -> (t, mkTree deps)) testSuites + , C.condBenchmarks = [] + } + } + pkgCheckErrors = + -- We ignore these warnings because some unit tests test that the + -- solver allows unknown extensions/languages when the compiler + -- supports them. + let ignore = ["Unknown extensions:", "Unknown languages:"] + in [ err | err <- C.checkPackage (packageDescription package) Nothing + , not $ any (`isPrefixOf` C.explanation err) ignore ] + in if null pkgCheckErrors + then package + else error $ "invalid GenericPackageDescription for package " + ++ display pkgId ++ ": " ++ show pkgCheckErrors + where + defaultTopLevelBuildInfo :: C.BuildInfo + defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } + + defaultLib :: C.Library + defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] } + + defaultExe :: C.Executable + defaultExe = mempty { C.modulePath = "Main.hs" } + + defaultTest :: C.TestSuite + defaultTest = mempty { + C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" + } + + -- Split the set of dependencies into the set of dependencies of the library, + -- the dependencies of the test suites and extensions. + splitTopLevel :: [ExampleDependency] + -> ( [ExampleDependency] + , [Extension] + , Maybe Language + , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config + , [(ExamplePkgName, C.VersionRange)] -- build tools + ) + splitTopLevel [] = + ([], [], Nothing, [], []) + splitTopLevel (ExBuildToolAny p:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, C.anyVersion):exes) + splitTopLevel (ExBuildToolFix p v:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, C.thisVersion (mkVersion v)):exes) + splitTopLevel (ExExt ext:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, ext:exts, lang, pcpkgs, exes) + splitTopLevel (ExLang lang:deps) = + case splitTopLevel deps of + (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes) + _ -> error "Only 1 Language dependency is supported" + splitTopLevel (ExPkg pkg:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pkg:pcpkgs, exes) + splitTopLevel (dep:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (dep:other, exts, lang, pcpkgs, exes) + + -- Extract the total set of flags used + extractFlags :: ExampleDependency -> [ExampleFlagName] + extractFlags (ExAny _) = [] + extractFlags (ExFix _ _) = [] + extractFlags (ExRange _ _ _) = [] + extractFlags (ExBuildToolAny _) = [] + extractFlags (ExBuildToolFix _ _) = [] + extractFlags (ExFlagged f a b) = + f : concatMap extractFlags (deps a ++ deps b) + where + deps :: Dependencies -> [ExampleDependency] + deps NotBuildable = [] + deps (Buildable ds) = ds + extractFlags (ExExt _) = [] + extractFlags (ExLang _) = [] + extractFlags (ExPkg _) = [] + + -- Convert a tree of BuildInfos into a tree of a specific component type. + -- 'defaultTopLevel' contains the default values for the component, and + -- 'mkComponent' creates a component from a 'BuildInfo'. + mkCondTree :: forall a. Semigroup a => + a -> (C.BuildInfo -> a) + -> DependencyTree C.BuildInfo + -> DependencyTree a + mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) = + C.CondNode { + C.condTreeData = + defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData) + , C.condTreeConstraints = topConstraints + , C.condTreeComponents = goComponents topComps + } + where + go :: DependencyTree C.BuildInfo -> DependencyTree a + go (C.CondNode ctData constraints comps) = + C.CondNode (mkComponent ctData) constraints (goComponents comps) + + goComponents :: [DependencyComponent C.BuildInfo] + -> [DependencyComponent a] + goComponents comps = [C.CondBranch cond (go t) (go <$> me) | C.CondBranch cond t me <- comps] + + mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo + mkBuildInfoTree NotBuildable = + C.CondNode { + C.condTreeData = mempty { C.buildable = False } + , C.condTreeConstraints = [] + , C.condTreeComponents = [] + } + mkBuildInfoTree (Buildable deps) = + let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps + (directDeps, flaggedDeps) = splitDeps libraryDeps + bi = mempty { + C.otherExtensions = exts + , C.defaultLanguage = mlang + , C.buildTools = [ C.LegacyExeDependency n vr + | (n,vr) <- buildTools ] + , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' + | (n,v) <- pcpkgs + , let n' = C.mkPkgconfigName n + , let v' = C.thisVersion (mkVersion v) ] + } + in C.CondNode { + C.condTreeData = bi -- Necessary for language extensions + -- TODO: Arguably, build-tools dependencies should also + -- effect constraints on conditional tree. But no way to + -- distinguish between them + , C.condTreeConstraints = map mkDirect directDeps + , C.condTreeComponents = map mkFlagged flaggedDeps + } + + mkDirect :: (ExamplePkgName, C.VersionRange) -> C.Dependency + mkDirect (dep, vr) = C.Dependency (C.mkPackageName dep) vr + + mkFlagged :: (ExampleFlagName, Dependencies, Dependencies) + -> DependencyComponent C.BuildInfo + mkFlagged (f, a, b) = + C.CondBranch (C.Var (C.Flag (C.mkFlagName f))) + (mkBuildInfoTree a) + (Just (mkBuildInfoTree b)) + + -- Split a set of dependencies into direct dependencies and flagged + -- dependencies. A direct dependency is a tuple of the name of package and + -- its version range meant to be converted to a 'C.Dependency' with + -- 'mkDirect' for example. A flagged dependency is the set of dependencies + -- guarded by a flag. + splitDeps :: [ExampleDependency] + -> ( [(ExamplePkgName, C.VersionRange)] + , [(ExampleFlagName, Dependencies, Dependencies)] + ) + splitDeps [] = + ([], []) + splitDeps (ExAny p:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.anyVersion):directDeps, flaggedDeps) + splitDeps (ExFix p v:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, C.thisVersion $ mkVersion v):directDeps, flaggedDeps) + splitDeps (ExRange p v1 v2:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps) + splitDeps (ExFlagged f a b:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in (directDeps, (f, a, b):flaggedDeps) + splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep + + -- custom-setup only supports simple dependencies + mkSetupDeps :: [ExampleDependency] -> [C.Dependency] + mkSetupDeps deps = + let (directDeps, []) = splitDeps deps in map mkDirect directDeps + +mkVersion :: ExamplePkgVersion -> C.Version +mkVersion n = C.mkVersion [n, 0, 0] + +mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange +mkVersionRange v1 v2 = + C.intersectVersionRanges (C.orLaterVersion $ mkVersion v1) + (C.earlierVersion $ mkVersion v2) + +mkFlag :: ExFlag -> C.Flag +mkFlag flag = C.MkFlag { + C.flagName = C.mkFlagName $ exFlagName flag + , C.flagDescription = "" + , C.flagDefault = exFlagDefault flag + , C.flagManual = + case exFlagType flag of + Manual -> True + Automatic -> False + } + +mkDefaultFlag :: ExampleFlagName -> C.Flag +mkDefaultFlag flag = C.MkFlag { + C.flagName = C.mkFlagName flag + , C.flagDescription = "" + , C.flagDefault = True + , C.flagManual = False + } + +exAvPkgId :: ExampleAvailable -> C.PackageIdentifier +exAvPkgId ex = C.PackageIdentifier { + pkgName = C.mkPackageName (exAvName ex) + , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] + } + +exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo +exInstInfo ex = IPI.emptyInstalledPackageInfo { + IPI.installedUnitId = C.mkUnitId (exInstHash ex) + , IPI.sourcePackageId = exInstPkgId ex + , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) + } + +exInstPkgId :: ExampleInstalled -> C.PackageIdentifier +exInstPkgId ex = C.PackageIdentifier { + pkgName = C.mkPackageName (exInstName ex) + , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] + } + +exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage +exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg + +exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex +exInstIdx = C.PackageIndex.fromList . map exInstInfo + +exResolve :: ExampleDb + -- List of extensions supported by the compiler, or Nothing if unknown. + -> Maybe [Extension] + -- List of languages supported by the compiler, or Nothing if unknown. + -> Maybe [Language] + -> PC.PkgConfigDb + -> [ExamplePkgName] + -> Solver + -> Maybe Int + -> IndependentGoals + -> ReorderGoals + -> AllowBootLibInstalls + -> EnableBackjumping + -> Maybe [ExampleVar] + -> [ExConstraint] + -> [ExPreference] + -> EnableAllTests + -> Progress String String CI.SolverInstallPlan.SolverInstallPlan +exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder + allowBootLibInstalls enableBj vars constraints prefs enableAllTests + = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params + where + defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag + compiler = defaultCompiler { C.compilerInfoExtensions = exts + , C.compilerInfoLanguages = langs + } + (inst, avai) = partitionEithers db + instIdx = exInstIdx inst + avaiIdx = SourcePackageDb { + packageIndex = exAvIdx avai + , packagePreferences = Map.empty + } + enableTests + | asBool enableAllTests = fmap (\p -> PackageConstraint + (scopeToplevel (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas])) + (exDbPkgs db) + | otherwise = [] + targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets + params = addConstraints (fmap toConstraint constraints) + $ addConstraints (fmap toLpc enableTests) + $ addPreferences (fmap toPref prefs) + $ setIndependentGoals indepGoals + $ setReorderGoals reorder + $ setMaxBackjumps mbj + $ setAllowBootLibInstalls allowBootLibInstalls + $ setEnableBackjumping enableBj + $ setGoalOrder goalOrder + $ standardInstallPolicy instIdx avaiIdx targets' + toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown + + toConstraint (ExVersionConstraint scope v) = + toLpc $ PackageConstraint scope (PackagePropertyVersion v) + toConstraint (ExFlagConstraint scope fn b) = + toLpc $ PackageConstraint scope (PackagePropertyFlags [(C.mkFlagName fn, b)]) + + toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v + toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas + + goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) + goalOrder = (orderFromList . map toVariable) `fmap` vars + + -- Sort elements in the list ahead of elements not in the list. Otherwise, + -- follow the order in the list. + orderFromList :: Eq a => [a] -> a -> a -> Ordering + orderFromList xs = + comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) + + toVariable :: ExampleVar -> Variable P.QPN + toVariable (P q pn) = PackageVar (toQPN q pn) + toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) + toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza + + toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN + toQPN q pn = P.Q pp (C.mkPackageName pn) + where + pp = case q of + None -> P.PackagePath P.DefaultNamespace P.QualToplevel + Indep x -> P.PackagePath (P.Independent x) P.QualToplevel + Setup p -> P.PackagePath P.DefaultNamespace (P.QualSetup (C.mkPackageName p)) + IndepSetup x p -> P.PackagePath (P.Independent x) (P.QualSetup (C.mkPackageName p)) + +extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan + -> [(ExamplePkgName, ExamplePkgVersion)] +extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList + where + confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) + confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg + confPkg _ = Nothing + + srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int) + srcPkg cpkg = + let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg) + in (C.unPackageName pn, head (C.versionNumbers ver)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Run Progress computation +runProgress :: Progress step e a -> ([step], Either e a) +runProgress = go + where + go (Step s p) = let (ss, result) = go p in (s:ss, result) + go (Fail e) = ([], Left e) + go (Done a) = ([], Right a) diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE RecordWildCards #-} +-- | Utilities for creating HUnit test cases with the solver DSL. +module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( + SolverTest + , SolverResult(..) + , independentGoals + , allowBootLibInstalls + , disableBackjumping + , goalOrder + , constraints + , preferences + , enableAllTests + , solverSuccess + , solverFailure + , anySolverFailure + , mkTest + , mkTestExts + , mkTestLangs + , mkTestPCDepends + , mkTestExtLangPC + , runTest + ) where + +-- test-framework +import Test.Tasty as TF +import Test.Tasty.HUnit (testCase, assertEqual, assertBool) + +-- Cabal +import Language.Haskell.Extension (Extension(..), Language(..)) + +-- cabal-install +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) +import Distribution.Solver.Types.Settings +import Distribution.Client.Dependency (foldProgress) +import Distribution.Client.Dependency.Types + ( Solver(Modular) ) +import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Options + +-- | Combinator to turn on --independent-goals behavior, i.e. solve +-- for the goals as if we were solving for each goal independently. +independentGoals :: SolverTest -> SolverTest +independentGoals test = test { testIndepGoals = IndependentGoals True } + +allowBootLibInstalls :: SolverTest -> SolverTest +allowBootLibInstalls test = + test { testAllowBootLibInstalls = AllowBootLibInstalls True } + +disableBackjumping :: SolverTest -> SolverTest +disableBackjumping test = + test { testEnableBackjumping = EnableBackjumping False } + +goalOrder :: [ExampleVar] -> SolverTest -> SolverTest +goalOrder order test = test { testGoalOrder = Just order } + +constraints :: [ExConstraint] -> SolverTest -> SolverTest +constraints cs test = test { testConstraints = cs } + +preferences :: [ExPreference] -> SolverTest -> SolverTest +preferences prefs test = test { testSoftConstraints = prefs } + +enableAllTests :: SolverTest -> SolverTest +enableAllTests test = test { testEnableAllTests = EnableAllTests True } + +{------------------------------------------------------------------------------- + Solver tests +-------------------------------------------------------------------------------} + +data SolverTest = SolverTest { + testLabel :: String + , testTargets :: [String] + , testResult :: SolverResult + , testIndepGoals :: IndependentGoals + , testAllowBootLibInstalls :: AllowBootLibInstalls + , testEnableBackjumping :: EnableBackjumping + , testGoalOrder :: Maybe [ExampleVar] + , testConstraints :: [ExConstraint] + , testSoftConstraints :: [ExPreference] + , testDb :: ExampleDb + , testSupportedExts :: Maybe [Extension] + , testSupportedLangs :: Maybe [Language] + , testPkgConfigDb :: PkgConfigDb + , testEnableAllTests :: EnableAllTests + } + +-- | Expected result of a solver test. +data SolverResult = SolverResult { + -- | The solver's log should satisfy this predicate. Note that we also print + -- the log, so evaluating a large log here can cause a space leak. + resultLogPredicate :: [String] -> Bool, + + -- | Fails with an error message satisfying the predicate, or succeeds with + -- the given plan. + resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] + } + +solverSuccess :: [(String, Int)] -> SolverResult +solverSuccess = SolverResult (const True) . Right + +solverFailure :: (String -> Bool) -> SolverResult +solverFailure = SolverResult (const True) . Left + +-- | Can be used for test cases where we just want to verify that +-- they fail, but do not care about the error message. +anySolverFailure :: SolverResult +anySolverFailure = solverFailure (const True) + +-- | Makes a solver test case, consisting of the following components: +-- +-- 1. An 'ExampleDb', representing the package database (both +-- installed and remote) we are doing dependency solving over, +-- 2. A 'String' name for the test, +-- 3. A list '[String]' of package names to solve for +-- 4. The expected result, either 'Nothing' if there is no +-- satisfying solution, or a list '[(String, Int)]' of +-- packages to install, at which versions. +-- +-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how +-- to construct an 'ExampleDb', as well as definitions of 'db1' etc. +-- in this file. +mkTest :: ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTest = mkTestExtLangPC Nothing Nothing [] + +mkTestExts :: [Extension] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] + +mkTestLangs :: [Language] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] + +mkTestPCDepends :: [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb + +mkTestExtLangPC :: Maybe [Extension] + -> Maybe [Language] + -> [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { + testLabel = label + , testTargets = targets + , testResult = result + , testIndepGoals = IndependentGoals False + , testAllowBootLibInstalls = AllowBootLibInstalls False + , testEnableBackjumping = EnableBackjumping True + , testGoalOrder = Nothing + , testConstraints = [] + , testSoftConstraints = [] + , testDb = db + , testSupportedExts = exts + , testSupportedLangs = langs + , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb + , testEnableAllTests = EnableAllTests False + } + +runTest :: SolverTest -> TF.TestTree +runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> + testCase testLabel $ do + let progress = exResolve testDb testSupportedExts + testSupportedLangs testPkgConfigDb testTargets + Modular Nothing testIndepGoals (ReorderGoals False) + testAllowBootLibInstalls testEnableBackjumping testGoalOrder + testConstraints testSoftConstraints testEnableAllTests + printMsg msg = if showSolverLog + then putStrLn msg + else return () + msgs = foldProgress (:) (const []) (const []) progress + assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ + resultLogPredicate testResult $ concatMap lines msgs + result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress + case result of + Left err -> assertBool ("Unexpected error:\n" ++ err) + (checkErrorMsg testResult err) + Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) + where + toMaybe :: SolverResult -> Maybe [(String, Int)] + toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan + + checkErrorMsg :: SolverResult -> String -> Bool + checkErrorMsg result msg = + case resultErrorMsgPredicateOrPlan result of + Left f -> f msg + Right _ -> False diff --git a/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs @@ -0,0 +1,97 @@ +-- | Tests for detecting space leaks in the dependency solver. +module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where + +import Test.Tasty (TestTree) + +import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + +tests :: [TestTree] +tests = [ + runTest $ basicTest "basic space leak test" + , runTest $ flagsTest "package with many flags" + , runTest $ issue2899 "issue #2899" + ] + +-- | This test solves for n packages that each have two versions. There is no +-- solution, because the nth package depends on another package that doesn't fit +-- its version constraint. Backjumping is disabled, so the solver must explore a +-- search tree of size 2^n. It should fail if memory usage is proportional to +-- the size of the tree. +basicTest :: String -> SolverTest +basicTest name = + disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure + where + n :: Int + n = 18 + + pkgs :: ExampleDb + pkgs = map Right $ + [ exAv "target" 1 [ExAny $ pkgName 1]] + ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4] + | i <- [1..n], v <- [2, 3]] + ++ [exAv (pkgName $ n + 1) 1 []] + + pkgName :: Int -> ExamplePkgName + pkgName x = "pkg-" ++ show x + +-- | This test is similar to 'basicTest', except that it has one package with n +-- flags, flag-1 through flag-n. The solver assigns flags in order, so it +-- doesn't discover the unknown dependencies under flag-n until it has assigned +-- all of the flags. It has to explore the whole search tree. +flagsTest :: String -> SolverTest +flagsTest name = + disableBackjumping $ + goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure + where + n :: Int + n = 16 + + pkgs :: ExampleDb + pkgs = [Right $ exAv "pkg" 1 $ + [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]] + + -- The remaining flags have no effect: + ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]] + ] + + flagName :: Int -> ExampleFlagName + flagName x = "flag-" ++ show x + + orderedFlags :: [ExampleVar] + orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]] + +-- | Test for a space leak caused by sharing of search trees under packages with +-- link choices (issue #2899). +-- +-- The goal order is fixed so that the solver chooses setup-dep and then +-- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep +-- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep +-- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n +-- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each +-- dependency has two versions, the solver must try 2^n combinations when +-- backjumping is disabled. These combinations create large search trees under +-- each of the two choices for target-setup.setup-dep. Although the choice to +-- not link is disallowed by the Single Instance Restriction, the solver doesn't +-- know that until it has explored (and evaluated) the whole tree under the +-- choice to link. If the two trees are shared, memory usage spikes. +issue2899 :: String -> SolverTest +issue2899 name = + disableBackjumping $ + goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure + where + n :: Int + n = 16 + + pkgs :: ExampleDb + pkgs = map Right $ + [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"] + , exAv "setup-dep" 1 [ExAny $ pkgName 1]] + ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)] + | i <- [1..n], v <- [1, 2]] + + pkgName :: Int -> ExamplePkgName + pkgName x = "pkg-" ++ show x + + goals :: [ExampleVar] + goals = [P None "setup-dep", P (Setup "target") "setup-dep"] diff --git a/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs b/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs @@ -0,0 +1,22 @@ +module UnitTests.Distribution.Solver.Modular.PSQ ( + tests + ) where + +import Distribution.Solver.Modular.PSQ + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = [ testProperty "splitsAltImplementation" splitsTest + ] + +-- | Original splits implementation +splits' :: PSQ k a -> PSQ k (a, PSQ k a) +splits' xs = + casePSQ xs + (PSQ []) + (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys))) + +splitsTest :: [(Int, Int)] -> Bool +splitsTest psq = splits' (PSQ psq) == splits (PSQ psq) diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where + +import Control.DeepSeq (NFData, force) +import Control.Monad (foldM) +import Data.Either (lefts) +import Data.Function (on) +import Data.List (groupBy, isInfixOf, nub, nubBy, sort) +import Data.Maybe (isJust) +import GHC.Generics (Generic) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (Monoid) +#endif + +import Text.Show.Pretty (parseValue, valToStr) + +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck + +import Distribution.Client.Dependency.Types + ( Solver(..) ) +import Distribution.Client.Setup (defaultMaxBackjumps) + +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps + ( Component(..), ComponentDep, ComponentDeps ) +import Distribution.Solver.Types.PkgConfigDb + (pkgConfigDbFromList) +import Distribution.Solver.Types.Settings + +import UnitTests.Distribution.Solver.Modular.DSL + +tests :: [TestTree] +tests = [ + -- This test checks that certain solver parameters do not affect the + -- existence of a solution. It runs the solver twice, and only sets those + -- parameters on the second run. The test also applies parameters that + -- can affect the existence of a solution to both runs. + testProperty "target order and --reorder-goals do not affect solvability" $ + \(SolverTest db targets) targetOrder reorderGoals indepGoals solver -> + let r1 = solve' (ReorderGoals False) targets db + r2 = solve' reorderGoals targets2 db + solve' reorder = solve (EnableBackjumping True) reorder + indepGoals solver + targets2 = case targetOrder of + SameOrder -> targets + ReverseOrder -> reverse targets + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + + , testProperty + "solvable without --independent-goals => solvable with --independent-goals" $ + \(SolverTest db targets) reorderGoals solver -> + let r1 = solve' (IndependentGoals False) targets db + r2 = solve' (IndependentGoals True) targets db + solve' indep = solve (EnableBackjumping True) + reorderGoals indep solver + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) `implies` isRight (resultPlan r2) + + , testProperty "backjumping does not affect solvability" $ + \(SolverTest db targets) reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) targets db + r2 = solve' (EnableBackjumping False) targets db + solve' enableBj = solve enableBj reorderGoals indepGoals Modular + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + ] + where + noneReachedBackjumpLimit :: [Result] -> Bool + noneReachedBackjumpLimit = + not . any (\r -> resultPlan r == Left BackjumpLimitReached) + + showResults :: Result -> Result -> String + showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2 + + showResult :: Int -> Result -> String + showResult n result = + unlines $ ["", "Run " ++ show n ++ ":"] + ++ resultLog result + ++ ["result: " ++ show (resultPlan result)] + + implies :: Bool -> Bool -> Bool + implies x y = not x || y + + isRight :: Either a b -> Bool + isRight (Right _) = True + isRight _ = False + +solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals + -> Solver -> [PN] -> TestDb -> Result +solve enableBj reorder indep solver targets (TestDb db) = + let (lg, result) = + runProgress $ exResolve db Nothing Nothing + (pkgConfigDbFromList []) + (map unPN targets) + solver + -- The backjump limit prevents individual tests from using + -- too much time and memory. + (Just defaultMaxBackjumps) + indep reorder (AllowBootLibInstalls False) enableBj Nothing [] [] + (EnableAllTests True) + + failure :: String -> Failure + failure msg + | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached + | otherwise = OtherFailure + in Result { + resultLog = lg + , resultPlan = + -- Force the result so that we check for internal errors when we check + -- for success or failure. See D.C.Dependency.validateSolverResult. + force $ either (Left . failure) (Right . extractInstallPlan) result + } + +-- | How to modify the order of the input targets. +data TargetOrder = SameOrder | ReverseOrder + deriving Show + +instance Arbitrary TargetOrder where + arbitrary = elements [SameOrder, ReverseOrder] + + shrink SameOrder = [] + shrink ReverseOrder = [SameOrder] + +data Result = Result { + resultLog :: [String] + , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)] + } + +data Failure = BackjumpLimitReached | OtherFailure + deriving (Eq, Generic, Show) + +instance NFData Failure + +-- | Package name. +newtype PN = PN { unPN :: String } + deriving (Eq, Ord, Show) + +instance Arbitrary PN where + arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']]) + +-- | Package version. +newtype PV = PV { unPV :: Int } + deriving (Eq, Ord, Show) + +instance Arbitrary PV where + arbitrary = PV <$> elements [1..10] + +type TestPackage = Either ExampleInstalled ExampleAvailable + +getName :: TestPackage -> PN +getName = PN . either exInstName exAvName + +getVersion :: TestPackage -> PV +getVersion = PV . either exInstVersion exAvVersion + +data SolverTest = SolverTest { + testDb :: TestDb + , testTargets :: [PN] + } + +-- | Pretty-print the test when quickcheck calls 'show'. +instance Show SolverTest where + show test = + let str = "SolverTest {testDb = " ++ show (testDb test) + ++ ", testTargets = " ++ show (testTargets test) ++ "}" + in maybe str valToStr $ parseValue str + +instance Arbitrary SolverTest where + arbitrary = do + db <- arbitrary + let pkgs = nub $ map getName (unTestDb db) + Positive n <- arbitrary + targets <- randomSubset n pkgs + return (SolverTest db targets) + + shrink test = + [test { testDb = db } | db <- shrink (testDb test)] + ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] + +-- | Collection of source and installed packages. +newtype TestDb = TestDb { unTestDb :: ExampleDb } + deriving Show + +instance Arbitrary TestDb where + arbitrary = do + -- Avoid cyclic dependencies by grouping packages by name and only + -- allowing each package to depend on packages in the groups before it. + groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<< + boundedListOf 10 arbitrary + db <- foldM nextPkgs (TestDb []) groupedPkgs + TestDb <$> shuffle (unTestDb db) + where + nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb + nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs + + nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage + nextPkg db (pn, v) = do + installed <- arbitrary + if installed + then Left <$> arbitraryExInst pn v (lefts $ unTestDb db) + else Right <$> arbitraryExAv pn v db + + shrink (TestDb pkgs) = map TestDb $ shrink pkgs + +arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable +arbitraryExAv pn v db = + (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db + +arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled +arbitraryExInst pn v pkgs = do + hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + numDeps <- min 3 <$> arbitrary + deps <- randomSubset numDeps pkgs + return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps) + +arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) +arbitraryComponentDeps (TestDb []) = return $ CD.fromList [] +arbitraryComponentDeps db = + -- dedupComponentNames removes components with duplicate names, for example, + -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines + -- duplicate unnamed components. + CD.fromList . dedupComponentNames <$> + boundedListOf 5 (arbitraryComponentDep db) + where + dedupComponentNames = + nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) + + componentName :: Component -> Maybe UnqualComponentName + componentName ComponentLib = Nothing + componentName ComponentSetup = Nothing + componentName (ComponentSubLib n) = Just n + componentName (ComponentFLib n) = Just n + componentName (ComponentExe n) = Just n + componentName (ComponentTest n) = Just n + componentName (ComponentBench n) = Just n + +arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency]) +arbitraryComponentDep db = do + comp <- arbitrary + deps <- case comp of + ComponentSetup -> smallListOf (arbitraryExDep db SetupDep) + _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep) + return (comp, deps) + +-- | Location of an 'ExampleDependency'. It determines which values are valid. +data ExDepLocation = SetupDep | NonSetupDep + +arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency +arbitraryExDep db@(TestDb pkgs) level = + let flag = ExFlagged <$> arbitraryFlagName + <*> arbitraryDeps db + <*> arbitraryDeps db + other = + -- Package checks require dependencies on "base" to have bounds. + let notBase = filter ((/= PN "base") . getName) pkgs + in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)] + ++ [ + -- existing version + let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg) + in fixed <$> elements pkgs + + -- random version of an existing package + , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary) + ] + in oneof $ + case level of + NonSetupDep -> flag : other + SetupDep -> other + +arbitraryDeps :: TestDb -> Gen Dependencies +arbitraryDeps db = frequency + [ (1, return NotBuildable) + , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep)) + ] + +arbitraryFlagName :: Gen String +arbitraryFlagName = (:[]) <$> elements ['A'..'E'] + +instance Arbitrary ReorderGoals where + arbitrary = ReorderGoals <$> arbitrary + + shrink (ReorderGoals reorder) = [ReorderGoals False | reorder] + +instance Arbitrary IndependentGoals where + arbitrary = IndependentGoals <$> arbitrary + + shrink (IndependentGoals indep) = [IndependentGoals False | indep] + +instance Arbitrary Solver where + arbitrary = return Modular + + shrink Modular = [] + +instance Arbitrary UnqualComponentName where + arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" + +instance Arbitrary Component where + arbitrary = oneof [ return ComponentLib + , ComponentSubLib <$> arbitrary + , ComponentExe <$> arbitrary + , ComponentFLib <$> arbitrary + , ComponentTest <$> arbitrary + , ComponentBench <$> arbitrary + , return ComponentSetup + ] + + shrink ComponentLib = [] + shrink _ = [ComponentLib] + +instance Arbitrary ExampleInstalled where + arbitrary = error "arbitrary not implemented: ExampleInstalled" + + shrink ei = [ ei { exInstBuildAgainst = deps } + | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)] + +instance Arbitrary ExampleAvailable where + arbitrary = error "arbitrary not implemented: ExampleAvailable" + + shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)] + +instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where + arbitrary = error "arbitrary not implemented: ComponentDeps" + + shrink = map CD.fromList . shrink . CD.toList + +instance Arbitrary ExampleDependency where + arbitrary = error "arbitrary not implemented: ExampleDependency" + + shrink (ExAny _) = [] + shrink (ExFix "base" _) = [] -- preserve bounds on base + shrink (ExFix pn _) = [ExAny pn] + shrink (ExFlagged flag th el) = + deps th ++ deps el + ++ [ExFlagged flag th' el | th' <- shrink th] + ++ [ExFlagged flag th el' | el' <- shrink el] + where + deps NotBuildable = [] + deps (Buildable ds) = ds + shrink dep = error $ "Dependency not handled: " ++ show dep + +instance Arbitrary Dependencies where + arbitrary = error "arbitrary not implemented: Dependencies" + + shrink NotBuildable = [Buildable []] + shrink (Buildable deps) = map Buildable (shrink deps) + +randomSubset :: Int -> [a] -> Gen [a] +randomSubset n xs = take n <$> shuffle xs + +boundedListOf :: Int -> Gen a -> Gen [a] +boundedListOf n gen = take n <$> listOf gen + +-- | Generates lists with average length less than 1. +smallListOf :: Gen a -> Gen [a] +smallListOf gen = + frequency [ (fr, vectorOf n gen) + | (fr, n) <- [(3, 0), (5, 1), (2, 2)]] diff --git a/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Distribution.Solver.Modular.RetryLog ( + tests + ) where + +import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.RetryLog +import Distribution.Solver.Types.Progress + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck + ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===)) + +type Log a = Progress a String String + +tests :: [TestTree] +tests = [ + testProperty "'toProgress . fromProgress' is identity" $ \p -> + toProgress (fromProgress p) === (p :: Log Int) + + , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $ + let mapFailureProgress f = foldProgress Step (Fail . f) Done + in \(Blind f) p -> + toProgress (mapFailure f (fromProgress p)) + === mapFailureProgress (f :: String -> Int) (p :: Log Int) + + , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $ + \p (Blind f) -> + toProgress (retry (fromProgress p) (fromProgress . f)) + === (foldProgress Step f Done (p :: Log Int) :: Log Int) + + , testProperty "failWith" $ \step failure -> + toProgress (failWith step failure) + === (Step step (Fail failure) :: Log Int) + + , testProperty "succeedWith" $ \step success -> + toProgress (succeedWith step success) + === (Step step (Done success) :: Log Int) + + , testProperty "continueWith" $ \step p -> + toProgress (continueWith step (fromProgress p)) + === (Step step p :: Log Int) + + , testCase "tryWith with failure" $ + let failure = Fail "Error" + s = Step Success + in toProgress (tryWith Success $ fromProgress (s (s failure))) + @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message) + + , testCase "tryWith with success" $ + let done = Done "Done" + s = Step Success + in toProgress (tryWith Success $ fromProgress (s (s done))) + @?= (s (Step Enter (s (s done))) :: Log Message) + ] + +instance (Arbitrary step, Arbitrary fail, Arbitrary done) + => Arbitrary (Progress step fail done) where + arbitrary = do + steps <- listOf arbitrary + end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary] + return $ foldr Step end steps + +deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done) + +deriving instance (Show step, Show fail, Show done) + => Show (Progress step fail done) + +deriving instance Eq Message +deriving instance Show Message diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -0,0 +1,1231 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This is a set of unit tests for the dependency solver, +-- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL") +-- to more conveniently create package databases to run the solver tests on. +module UnitTests.Distribution.Solver.Modular.Solver (tests) + where + +-- base +import Data.List (isInfixOf) + +import qualified Distribution.Version as V + +-- test-framework +import Test.Tasty as TF + +-- Cabal +import Language.Haskell.Extension ( Extension(..) + , KnownExtension(..), Language(..)) + +-- cabal-install +import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath +import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + +tests :: [TF.TestTree] +tests = [ + testGroup "Simple dependencies" [ + runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) + , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) + , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) + , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) + , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)]) + , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)]) + , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) + , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure + , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) + , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) + ] + , testGroup "Flagged dependencies" [ + runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)]) + , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure + , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) + ] + , testGroup "Manual flags" [ + runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ + solverSuccess [("pkg", 1), ("true-dep", 1)] + + , let checkFullLog = + any $ isInfixOf "rejecting: pkg-1.0.0:-flag (manual flag can only be changed explicitly)" + in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ + -- TODO: We should check the summarized log instead of the full log + -- for the manual flags error message, but it currently only + -- appears in the full log. + SolverResult checkFullLog (Left $ const True) + + , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + in runTest $ constraints cs $ + mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ + solverSuccess [("false-dep", 1), ("pkg", 1)] + ] + , testGroup "Qualified manual flag constraints" [ + let name = "Top-level flag constraint does not constrain setup dep's flag" + cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ] + + , let name = "Solver can toggle setup dep's flag to match top-level constraint" + cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False + , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ] + + , let name = "User can constrain flags separately with qualified constraints" + cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ] + + -- Regression test for #4299 + , let name = "Solver can link deps when only one has constrained manual flag" + cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False] + in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ] + + , let name = "Solver cannot link deps that have conflicting manual flag constraints" + cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ] + failureReason = "(constraint from unknown source requires opposite flag selection)" + checkFullLog lns = + all (\msg -> any (msg `isInfixOf`) lns) + [ "rejecting: B-1.0.0:-flag " ++ failureReason + , "rejecting: A:setup.B-1.0.0:+flag " ++ failureReason ] + in runTest $ constraints cs $ + mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + SolverResult checkFullLog (Left $ const True) + ] + , testGroup "Stanzas" [ + runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure + , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO + , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)]) + , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure + , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) + , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) + ] + , testGroup "Setup dependencies" [ + runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) + , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)]) + , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)]) + , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)]) + , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)]) + , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) + , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)]) + , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) + ] + , testGroup "Base shim" [ + runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)]) + , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure + , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) + ] + , testGroup "Base" [ + runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ + solverFailure (isInfixOf "only already installed instances can be used") + , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ + solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] + ] + , testGroup "Cycles" [ + runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure + , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure + , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure + , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure + , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) + , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) + , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" + ] + , testGroup "Extensions" [ + runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure + , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure + , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)]) + , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)]) + , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure + , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure + , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)]) + ] + , testGroup "Languages" [ + runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure + , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)]) + , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure + , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)]) + ] + , testGroup "Qualified Package Constraints" [ + runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] + + , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ] + in runTest $ constraints cs $ + mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] + + , let cs = [ ExVersionConstraint (ScopeQualified QualToplevel "D") $ mkVersionRange 1 4 + , ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7 + ] + in runTest $ constraints cs $ + mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] + + , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ] + in runTest $ constraints cs $ + mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)] + ] + , testGroup "Package Preferences" [ + runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)]) + , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)]) + , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2 + , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)]) + , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1 + , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)]) + , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 + , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)]) + , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 + , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)]) + ] + , testGroup "Stanza Preferences" [ + runTest $ + mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $ + solverSuccess [("pkg", 1)] + + , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ + mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $ + solverSuccess [("pkg", 1), ("test-dep", 1)] + + , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ + mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ + solverSuccess [("pkg", 1)] + ] + , testGroup "Buildable Field" [ + testBuildable "avoid building component with unknown dependency" (ExAny "unknown") + , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown")) + , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown")) + , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)]) + , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)]) + ] + , testGroup "Pkg-config dependencies" [ + runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure + , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure + , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)]) + ] + , testGroup "Independent goals" [ + runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) + , runTest $ testIndepGoals2 "indepGoals2" + , runTest $ testIndepGoals3 "indepGoals3" + , runTest $ testIndepGoals4 "indepGoals4" + , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder + , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder + , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder + , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder + ] + -- Tests designed for the backjumping blog post + , testGroup "Backjumping" [ + runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) + , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) + , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) + , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) + ] + -- Build-tools dependencies + , testGroup "build-tools" [ + runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) + , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)]) + , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) + , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) + , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) + , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) + ] + -- Tests for the contents of the solver's log + , testGroup "Solver log" [ + -- See issue #3203. The solver should only choose a version for A once. + runTest $ + let db = [Right $ exAv "A" 1 []] + + p :: [String] -> Bool + p lg = elem "targets: A" lg + && length (filter ("trying: A" `isInfixOf`) lg) == 1 + in mkTest db "deduplicate targets" ["A", "A"] $ + SolverResult p $ Right [("A", 1)] + , runTest $ + let db = [Right $ exAv "A" 1 [ExAny "B"]] + msg = "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, B" + in mkTest db "exhaustive search failure message" ["A"] $ + solverFailure (isInfixOf msg) + ] + ] + where + indep = independentGoals + mkvrThis = V.thisVersion . makeV + mkvrOrEarlier = V.orEarlierVersion . makeV + makeV v = V.mkVersion [v,0,0] + +data GoalOrder = FixedGoalOrder | DefaultGoalOrder + +{------------------------------------------------------------------------------- + Specific example database for the tests +-------------------------------------------------------------------------------} + +db1 :: ExampleDb +db1 = + let a = exInst "A" 1 "A-1" [] + in [ Left a + , Right $ exAv "B" 1 [ExAny "A"] + , Right $ exAv "B" 2 [ExAny "A"] + , Right $ exAv "C" 1 [ExFix "B" 1] + , Right $ exAv "D" 1 [ExFix "B" 2] + , Right $ exAv "E" 1 [ExAny "B"] + , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"] + , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"] + , Right $ exAv "Z" 1 [] + ] + +-- In this example, we _can_ install C and D as independent goals, but we have +-- to pick two diferent versions for B (arbitrarily) +db2 :: ExampleDb +db2 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [ExAny "A"] + , Right $ exAv "B" 2 [ExAny "A"] + , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1] + , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2] + ] + +db3 :: ExampleDb +db3 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]] + , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] + , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] + ] + +-- | Like db3, but the flag picks a different package rather than a +-- different package version +-- +-- In db3 we cannot install C and D as independent goals because: +-- +-- * The multiple instance restriction says C and D _must_ share B +-- * Since C relies on A-1, C needs B to be compiled with flagB on +-- * Since D relies on A-2, D needs B to be compiled with flagB off +-- * Hence C and D have incompatible requirements on B's flags. +-- +-- However, _even_ if we don't check explicitly that we pick the same flag +-- assignment for 0.B and 1.B, we will still detect the problem because +-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to +-- 1.A and therefore we cannot link 0.B to 1.B. +-- +-- In db4 the situation however is trickier. We again cannot install +-- packages C and D as independent goals because: +-- +-- * As above, the multiple instance restriction says that C and D _must_ share B +-- * Since C relies on Ax-2, it requires B to be compiled with flagB off +-- * Since D relies on Ay-2, it requires B to be compiled with flagB on +-- * Hence C and D have incompatible requirements on B's flags. +-- +-- But now this requirement is more indirect. If we only check dependencies +-- we don't see the problem: +-- +-- * We link 0.B to 1.B +-- * 0.B relies on Ay-1 +-- * 1.B relies on Ax-1 +-- +-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since +-- we only ever assign to one of these, these constraints are never broken. +db4 :: ExampleDb +db4 = [ + Right $ exAv "Ax" 1 [] + , Right $ exAv "Ax" 2 [] + , Right $ exAv "Ay" 1 [] + , Right $ exAv "Ay" 2 [] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] + , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] + , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] + ] + +-- | Simple database containing one package with a manual flag. +dbManualFlags :: ExampleDb +dbManualFlags = [ + Right $ declareFlags [ExFlag "flag" True Manual] $ + exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]] + , Right $ exAv "true-dep" 1 [] + , Right $ exAv "false-dep" 1 [] + ] + +-- | Database containing a setup dependency with a manual flag. A's library and +-- setup script depend on two different versions of B. B's manual flag can be +-- set to different values in the two places where it is used. +dbSetupDepWithManualFlag :: ExampleDb +dbSetupDepWithManualFlag = + let bFlags = [ExFlag "flag" True Manual] + in [ + Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2] + , Right $ declareFlags bFlags $ + exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"]] + , Right $ declareFlags bFlags $ + exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"] + [ExAny "b-2-false-dep"]] + , Right $ exAv "b-1-true-dep" 1 [] + , Right $ exAv "b-1-false-dep" 1 [] + , Right $ exAv "b-2-true-dep" 1 [] + , Right $ exAv "b-2-false-dep" 1 [] + ] + +-- | A database similar to 'dbSetupDepWithManualFlag', except that the library +-- and setup script both depend on B-1. B must be linked because of the Single +-- Instance Restriction, and its flag can only have one value. +dbLinkedSetupDepWithManualFlag :: ExampleDb +dbLinkedSetupDepWithManualFlag = [ + Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1] + , Right $ declareFlags [ExFlag "flag" True Manual] $ + exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"]] + , Right $ exAv "b-1-true-dep" 1 [] + , Right $ exAv "b-1-false-dep" 1 [] + ] + +-- | Some tests involving testsuites +-- +-- Note that in this test framework test suites are always enabled; if you +-- want to test without test suites just set up a test database without +-- test suites. +-- +-- * C depends on A (through its test suite) +-- * D depends on B-2 (through its test suite), but B-2 is unavailable +-- * E depends on A-1 directly and on A through its test suite. We prefer +-- to use A-1 for the test suite in this case. +-- * F depends on A-1 directly and on A-2 through its test suite. In this +-- case we currently fail to install F, although strictly speaking +-- test suites should be considered independent goals. +-- * G is like E, but for version A-2. This means that if we cannot install +-- E and G together, unless we regard them as independent goals. +db5 :: ExampleDb +db5 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"] + , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2] + , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"] + , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2] + , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"] + ] + +-- Now the _dependencies_ have test suites +-- +-- * Installing C is a simple example. C wants version 1 of A, but depends on +-- B, and B's testsuite depends on an any version of A. In this case we prefer +-- to link (if we don't regard test suites as independent goals then of course +-- linking here doesn't even come into it). +-- * Installing [C, D] means that we prefer to link B -- depending on how we +-- set things up, this means that we should also link their test suites. +db6 :: ExampleDb +db6 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"] + , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] + , Right $ exAv "D" 1 [ExAny "B"] + ] + +-- Packages with setup dependencies +-- +-- Install.. +-- * B: Simple example, just make sure setup deps are taken into account at all +-- * C: Both the package and the setup script depend on any version of A. +-- In this case we prefer to link +-- * D: Variation on C.1 where the package requires a specific (not latest) +-- version but the setup dependency is not fixed. Again, we prefer to +-- link (picking the older version) +-- * E: Variation on C.2 with the setup dependency the more inflexible. +-- Currently, in this case we do not see the opportunity to link because +-- we consider setup dependencies after normal dependencies; we will +-- pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick +-- A.1 instead. This isn't so easy to fix (if we want to fix it at all); +-- in particular, considering setup dependencies _before_ other deps is +-- not an improvement, because in general we would prefer to link setup +-- setups to package deps, rather than the other way around. (For example, +-- if we change this ordering then the test for D would start to install +-- two versions of A). +-- * F: The package and the setup script depend on different versions of A. +-- This will only work if setup dependencies are considered independent. +db7 :: ExampleDb +db7 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"] + , Right $ exAv "C" 1 [ExAny "A" ] `withSetupDeps` [ExAny "A" ] + , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A" ] + , Right $ exAv "E" 1 [ExAny "A" ] `withSetupDeps` [ExFix "A" 1] + , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] + ] + +-- If we install C and D together (not as independent goals), we need to build +-- both B.1 and B.2, both of which depend on A. +db8 :: ExampleDb +db8 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "B" 1 [ExAny "A"] + , Right $ exAv "B" 2 [ExAny "A"] + , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1] + , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2] + ] + +-- Extended version of `db8` so that we have nested setup dependencies +db9 :: ExampleDb +db9 = db8 ++ [ + Right $ exAv "E" 1 [ExAny "C"] + , Right $ exAv "E" 2 [ExAny "D"] + , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1] + , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2] + ] + +-- Multiple already-installed packages with inter-dependencies, and one package +-- (C) that depends on package A-1 for its setup script and package A-2 as a +-- library dependency. +db10 :: ExampleDb +db10 = + let rts = exInst "rts" 1 "rts-inst" [] + ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts] + base = exInst "base" 1 "base-inst" [rts, ghc_prim] + a1 = exInst "A" 1 "A1-inst" [base] + a2 = exInst "A" 2 "A2-inst" [base] + in [ + Left rts + , Left ghc_prim + , Left base + , Left a1 + , Left a2 + , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] + ] + +-- | This database tests that a package's setup dependencies are correctly +-- linked when the package is linked. See pull request #3268. +-- +-- When A and B are installed as independent goals, their dependencies on C must +-- be linked, due to the single instance restriction. Since C depends on D, 0.D +-- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D +-- and 1.C-setup.D must be linked. However, D's two link groups must remain +-- independent. The solver should be able to choose D-1 for C's library and D-2 +-- for C's setup script. +dbSetupDeps :: ExampleDb +dbSetupDeps = [ + Right $ exAv "A" 1 [ExAny "C"] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + ] + +-- | Tests for dealing with base shims +db11 :: ExampleDb +db11 = + let base3 = exInst "base" 3 "base-3-inst" [base4] + base4 = exInst "base" 4 "base-4-inst" [] + in [ + Left base3 + , Left base4 + , Right $ exAv "A" 1 [ExFix "base" 3] + ] + +-- | Slightly more realistic version of db11 where base-3 depends on syb +-- This means that if a package depends on base-3 and on syb, then they MUST +-- share the version of syb +-- +-- * Package A relies on base-3 (which relies on base-4) +-- * Package B relies on base-4 +-- * Package C relies on both A and B +-- * Package D relies on base-3 and on syb-2, which is not possible because +-- base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier) +-- * Package E relies on base-4 and on syb-2, which is fine. +db12 :: ExampleDb +db12 = + let base3 = exInst "base" 3 "base-3-inst" [base4, syb1] + base4 = exInst "base" 4 "base-4-inst" [] + syb1 = exInst "syb" 1 "syb-1-inst" [base4] + in [ + Left base3 + , Left base4 + , Left syb1 + , Right $ exAv "syb" 2 [ExFix "base" 4] + , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"] + , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"] + , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] + , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2] + , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] + ] + +dbBase :: ExampleDb +dbBase = [ + Right $ exAv "base" 1 + [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"] + , Right $ exAv "ghc-prim" 1 [] + , Right $ exAv "integer-simple" 1 [] + , Right $ exAv "integer-gmp" 1 [] + ] + +db13 :: ExampleDb +db13 = [ + Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [] + , Right $ exAv "A" 3 [] + ] + +-- | A, B, and C have three different dependencies on D that can be set to +-- different versions with qualified constraints. Each version of D can only +-- be depended upon by one version of A, B, or C, so that the versions of A, B, +-- and C in the install plan indicate which version of D was chosen for each +-- dependency. The one-to-one correspondence between versions of A, B, and C and +-- versions of D also prevents linking, which would complicate the solver's +-- behavior. +dbConstraints :: ExampleDb +dbConstraints = + [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]] + ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]] + ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]] + ++ [Right $ exAv "D" v [] | v <- [1..9]] + +dbStanzaPreferences1 :: ExampleDb +dbStanzaPreferences1 = [ + Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"] + , Right $ exAv "test-dep" 1 [] + ] + +dbStanzaPreferences2 :: ExampleDb +dbStanzaPreferences2 = [ + Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"] + ] + +-- | Database with some cycles +-- +-- * Simplest non-trivial cycle: A -> B and B -> A +-- * There is a cycle C -> D -> C, but it can be broken by picking the +-- right flag assignment. +db14 :: ExampleDb +db14 = [ + Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "A"] + , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]] + , Right $ exAv "D" 1 [ExAny "C"] + , Right $ exAv "E" 1 [] + ] + +-- | Cycles through setup dependencies +-- +-- The first cycle is unsolvable: package A has a setup dependency on B, +-- B has a regular dependency on A, and we only have a single version available +-- for both. +-- +-- The second cycle can be broken by picking different versions: package C-2.0 +-- has a setup dependency on D, and D has a regular dependency on C-*. However, +-- version C-1.0 is already available (perhaps it didn't have this setup dep). +-- Thus, we should be able to break this cycle even if we are installing package +-- E, which explictly depends on C-2.0. +db15 :: ExampleDb +db15 = [ + -- First example (real cycle, no solution) + Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "A"] + -- Second example (cycle can be broken by picking versions carefully) + , Left $ exInst "C" 1 "C-1-inst" [] + , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] + , Right $ exAv "D" 1 [ExAny "C" ] + , Right $ exAv "E" 1 [ExFix "C" 2] + ] + +-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack +-- as soon as it chooses the last package in the cycle, to avoid searching parts +-- of the tree that have no solution. Since there is no way to break the cycle, +-- it should fail with an error message describing the cycle. +testCyclicDependencyErrorMessages :: String -> SolverTest +testCyclicDependencyErrorMessages name = + goalOrder goals $ + mkTest db name ["pkg-A"] $ + SolverResult checkFullLog $ Left checkSummarizedLog + where + db :: ExampleDb + db = [ + Right $ exAv "pkg-A" 1 [ExAny "pkg-B"] + , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"] + , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"] + , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"] + , Right $ exAv "pkg-E" 1 [] + ] + + -- The solver should backtrack as soon as pkg-A, pkg-B, and pkg-C form a + -- cycle. It shouldn't try pkg-D or pkg-E. + checkFullLog :: [String] -> Bool + checkFullLog = + not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l) + + checkSummarizedLog :: String -> Bool + checkSummarizedLog = + isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)" + + -- Solve for pkg-D and pkg-E last. + goals :: [ExampleVar] + goals = [P None ("pkg-" ++ [c]) | c <- ['A'..'E']] + +-- | Check that the solver can backtrack after encountering the SIR (issue #2843) +-- +-- When A and B are installed as independent goals, the single instance +-- restriction prevents B from depending on C. This database tests that the +-- solver can backtrack after encountering the single instance restriction and +-- choose the only valid flag assignment (-flagA +flagB): +-- +-- > flagA flagB B depends on +-- > On _ C-* +-- > Off On E-* <-- only valid flag assignment +-- > Off Off D-2.0, C-* +-- +-- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D, +-- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have +-- C in the transitive closure of B's dependencies, because that would mean we +-- would need two instances of C: one built against D-1.0 and one built against +-- D-2.0. +db16 :: ExampleDb +db16 = [ + Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] + , Right $ exAv "B" 1 [ ExFix "D" 2 + , exFlagged "flagA" + [ExAny "C"] + [exFlagged "flagB" + [ExAny "E"] + [ExAny "C"]]] + , Right $ exAv "C" 1 [ExAny "D"] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + , Right $ exAv "E" 1 [] + ] + +-- | This test checks that when the solver discovers a constraint on a +-- package's version after choosing to link that package, it can backtrack to +-- try alternative versions for the linked-to package. See pull request #3327. +-- +-- When A and B are installed as independent goals, their dependencies on C +-- must be linked. Since C depends on D, A and B's dependencies on D must also +-- be linked. This test fixes the goal order so that the solver chooses D-2 for +-- both 0.D and 1.D before it encounters the test suites' constraints. The +-- solver must backtrack to try D-1 for both 0.D and 1.D. +testIndepGoals2 :: String -> SolverTest +testIndepGoals2 name = + goalOrder goals $ independentGoals $ + enableAllTests $ mkTest db name ["A", "B"] $ + solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] + , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] + , Right $ exAv "C" 1 [ExAny "D"] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + ] + + goals :: [ExampleVar] + goals = [ + P (Indep 0) "A" + , P (Indep 0) "C" + , P (Indep 0) "D" + , P (Indep 1) "B" + , P (Indep 1) "C" + , P (Indep 1) "D" + , S (Indep 1) "B" TestStanzas + , S (Indep 0) "A" TestStanzas + ] + +-- | Issue #2834 +-- When both A and B are installed as independent goals, their dependencies on +-- C must be linked. The only combination of C's flags that is consistent with +-- A and B's dependencies on D is -flagA +flagB. This database tests that the +-- solver can backtrack to find the right combination of flags (requiring F, but +-- not E or G) and apply it to both 0.C and 1.C. +-- +-- > flagA flagB C depends on +-- > On _ D-1, E-* +-- > Off On F-* <-- Only valid choice +-- > Off Off D-2, G-* +-- +-- The single instance restriction means we cannot have one instance of C +-- built against D-1 and one instance built against D-2; since A depends on +-- D-1, and B depends on C-2, it is therefore important that C cannot depend +-- on any version of D. +db18 :: ExampleDb +db18 = [ + Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] + , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] + , Right $ exAv "C" 1 [exFlagged "flagA" + [ExFix "D" 1, ExAny "E"] + [exFlagged "flagB" + [ExAny "F"] + [ExFix "D" 2, ExAny "G"]]] + , Right $ exAv "D" 1 [] + , Right $ exAv "D" 2 [] + , Right $ exAv "E" 1 [] + , Right $ exAv "F" 1 [] + , Right $ exAv "G" 1 [] + ] + +-- | Tricky test case with independent goals (issue #2842) +-- +-- Suppose we are installing D, E, and F as independent goals: +-- +-- * D depends on A-* and C-1, requiring A-1 to be built against C-1 +-- * E depends on B-* and C-2, requiring B-1 to be built against C-2 +-- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built +-- against the same version of C, violating the single instance restriction. +-- +-- We can visualize this DB as: +-- +-- > C-1 C-2 +-- > /|\ /|\ +-- > / | \ / | \ +-- > / | X | \ +-- > | | / \ | | +-- > | |/ \| | +-- > | + + | +-- > | | | | +-- > | A B | +-- > \ |\ /| / +-- > \ | \ / | / +-- > \| V |/ +-- > D F E +testIndepGoals3 :: String -> SolverTest +testIndepGoals3 name = + goalOrder goals $ independentGoals $ + mkTest db name ["D", "E", "F"] anySolverFailure + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ExAny "C"] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [] + , Right $ exAv "C" 2 [] + , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1] + , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2] + , Right $ exAv "F" 1 [ExAny "A", ExAny "B"] + ] + + goals :: [ExampleVar] + goals = [ + P (Indep 0) "D" + , P (Indep 0) "C" + , P (Indep 0) "A" + , P (Indep 1) "E" + , P (Indep 1) "C" + , P (Indep 1) "B" + , P (Indep 2) "F" + , P (Indep 2) "B" + , P (Indep 2) "C" + , P (Indep 2) "A" + ] + +-- | This test checks that the solver correctly backjumps when dependencies +-- of linked packages are not linked. It is an example where the conflict set +-- from enforcing the single instance restriction is not sufficient. See pull +-- request #3327. +-- +-- When A, B, and C are installed as independent goals with the specified goal +-- order, the first choice that the solver makes for E is 0.E-2. Then, when it +-- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally, +-- the solver discovers C's test's constraint on E. It must backtrack to try +-- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead +-- to a solution, because 0.E's version is constrained by A and cannot be +-- changed. +testIndepGoals4 :: String -> SolverTest +testIndepGoals4 name = + goalOrder goals $ independentGoals $ + enableAllTests $ mkTest db name ["A", "B", "C"] $ + solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)] + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ExFix "E" 2] + , Right $ exAv "B" 1 [ExAny "D"] + , Right $ exAv "C" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "E" 1] + , Right $ exAv "D" 1 [ExAny "E"] + , Right $ exAv "E" 1 [] + , Right $ exAv "E" 2 [] + ] + + goals :: [ExampleVar] + goals = [ + P (Indep 0) "A" + , P (Indep 0) "E" + , P (Indep 1) "B" + , P (Indep 1) "D" + , P (Indep 1) "E" + , P (Indep 2) "C" + , P (Indep 2) "D" + , P (Indep 2) "E" + , S (Indep 2) "C" TestStanzas + ] + +-- | Test the trace messages that we get when a package refers to an unknown pkg +-- +-- TODO: Currently we don't actually test the trace messages, and this particular +-- test still suceeds. The trace can only be verified by hand. +db21 :: ExampleDb +db21 = [ + Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown + , Right $ exAv "B" 1 [] + ] + +-- | A variant of 'db21', which actually fails. +db22 :: ExampleDb +db22 = [ + Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "A" 2 [ExAny "C"] + ] + +-- | Another test for the unknown package message. This database tests that +-- filtering out redundant conflict set messages in the solver log doesn't +-- interfere with generating a message about a missing package (part of issue +-- #3617). The conflict set for the missing package is {A, B}. That conflict set +-- is propagated up the tree to the level of A. Since the conflict set is the +-- same at both levels, the solver only keeps one of the backjumping messages. +db23 :: ExampleDb +db23 = [ + Right $ exAv "A" 1 [ExAny "B"] + ] + +-- | Database for (unsuccessfully) trying to expose a bug in the handling +-- of implied linking constraints. The question is whether an implied linking +-- constraint should only have the introducing package in its conflict set, +-- or also its link target. +-- +-- It turns out that as long as the Single Instance Restriction is in place, +-- it does not matter, because there will aways be an option that is failing +-- due to the SIR, which contains the link target in its conflict set. +-- +-- Even if the SIR is not in place, if there is a solution, one will always +-- be found, because without the SIR, linking is always optional, but never +-- necessary. +-- +testIndepGoals5 :: String -> GoalOrder -> SolverTest +testIndepGoals5 name fixGoalOrder = + case fixGoalOrder of + FixedGoalOrder -> goalOrder goals test + DefaultGoalOrder -> test + where + test :: SolverTest + test = independentGoals $ mkTest db name ["X", "Y"] $ + solverSuccess + [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] + + db :: ExampleDb + db = [ + Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] + , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2] + , Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [] + , Right $ exAv "C" 2 [] + ] + + goals :: [ExampleVar] + goals = [ + P (Indep 0) "X" + , P (Indep 0) "A" + , P (Indep 0) "B" + , P (Indep 0) "C" + , P (Indep 1) "Y" + , P (Indep 1) "A" + , P (Indep 1) "B" + , P (Indep 1) "C" + ] + +-- | A simplified version of 'testIndepGoals5'. +testIndepGoals6 :: String -> GoalOrder -> SolverTest +testIndepGoals6 name fixGoalOrder = + case fixGoalOrder of + FixedGoalOrder -> goalOrder goals test + DefaultGoalOrder -> test + where + test :: SolverTest + test = independentGoals $ mkTest db name ["X", "Y"] $ + solverSuccess + [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] + + db :: ExampleDb + db = [ + Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] + , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2] + , Right $ exAv "A" 1 [] + , Right $ exAv "A" 2 [ExAny "B"] + , Right $ exAv "B" 1 [] + , Right $ exAv "B" 2 [] + ] + + goals :: [ExampleVar] + goals = [ + P (Indep 0) "X" + , P (Indep 0) "A" + , P (Indep 0) "B" + , P (Indep 1) "Y" + , P (Indep 1) "A" + , P (Indep 1) "B" + ] + +dbExts1 :: ExampleDb +dbExts1 = [ + Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] + , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"] + , Right $ exAv "C" 1 [ExAny "B"] + , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"] + , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"] + ] + +dbLangs1 :: ExampleDb +dbLangs1 = [ + Right $ exAv "A" 1 [ExLang Haskell2010] + , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"] + , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] + ] + +-- | cabal must set enable-exe to false in order to avoid the unavailable +-- dependency. Flags are true by default. The flag choice causes "pkg" to +-- depend on "false-dep". +testBuildable :: String -> ExampleDependency -> TestTree +testBuildable testName unavailableDep = + runTest $ + mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected + where + expected = solverSuccess [("false-dep", 1), ("pkg", 1)] + db = [ + Right $ exAv "pkg" 1 [exFlagged "enable-exe" + [ExAny "true-dep"] + [ExAny "false-dep"]] + `withExe` + ExExe "exe" [ unavailableDep + , ExFlagged "enable-exe" (Buildable []) NotBuildable ] + , Right $ exAv "true-dep" 1 [] + , Right $ exAv "false-dep" 1 [] + ] + +-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages +-- "flag1-false" and "flag2-true". +dbBuildable1 :: ExampleDb +dbBuildable1 = [ + Right $ exAv "pkg" 1 + [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] + , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] + `withExes` + [ ExExe "exe1" + [ ExAny "unknown" + , ExFlagged "flag1" (Buildable []) NotBuildable + , ExFlagged "flag2" (Buildable []) NotBuildable] + , ExExe "exe2" + [ ExAny "unknown" + , ExFlagged "flag1" + (Buildable []) + (Buildable [ExFlagged "flag2" NotBuildable (Buildable [])])] + ] + , Right $ exAv "flag1-true" 1 [] + , Right $ exAv "flag1-false" 1 [] + , Right $ exAv "flag2-true" 1 [] + , Right $ exAv "flag2-false" 1 [] + ] + +-- | cabal must pick B-2 to avoid the unknown dependency. +dbBuildable2 :: ExampleDb +dbBuildable2 = [ + Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [ExAny "unknown"] + , Right $ exAv "B" 2 [] + `withExe` + ExExe "exe" + [ ExAny "unknown" + , ExFlagged "disable-exe" NotBuildable (Buildable []) + ] + , Right $ exAv "B" 3 [ExAny "unknown"] + ] + +-- | Package databases for testing @pkg-config@ dependencies. +dbPC1 :: ExampleDb +dbPC1 = [ + Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] + , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] + , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] + , Right $ exAv "C" 1 [ExAny "B"] + ] + +{------------------------------------------------------------------------------- + Simple databases for the illustrations for the backjumping blog post +-------------------------------------------------------------------------------} + +-- | Motivate conflict sets +dbBJ1a :: ExampleDb +dbBJ1a = [ + Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "A" 2 [ExFix "B" 2] + , Right $ exAv "B" 1 [] + ] + +-- | Show that we can skip some decisions +dbBJ1b :: ExampleDb +dbBJ1b = [ + Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"] + , Right $ exAv "B" 1 [] + , Right $ exAv "C" 1 [] + , Right $ exAv "C" 2 [] + ] + +-- | Motivate why both A and B need to be in the conflict set +dbBJ1c :: ExampleDb +dbBJ1c = [ + Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "B" 1 [] + , Right $ exAv "B" 2 [] + ] + +-- | Motivate the need for accumulating conflict sets while we walk the tree +dbBJ2 :: ExampleDb +dbBJ2 = [ + Right $ exAv "A" 1 [ExFix "B" 1] + , Right $ exAv "A" 2 [ExFix "B" 2] + , Right $ exAv "B" 1 [ExFix "C" 1] + , Right $ exAv "B" 2 [ExFix "C" 2] + , Right $ exAv "C" 1 [] + ] + +-- | Motivate the need for `QGoalReason` +dbBJ3 :: ExampleDb +dbBJ3 = [ + Right $ exAv "A" 1 [ExAny "Ba"] + , Right $ exAv "A" 2 [ExAny "Bb"] + , Right $ exAv "Ba" 1 [ExFix "C" 1] + , Right $ exAv "Bb" 1 [ExFix "C" 2] + , Right $ exAv "C" 1 [] + ] + +-- | `QGOalReason` not unique +dbBJ4 :: ExampleDb +dbBJ4 = [ + Right $ exAv "A" 1 [ExAny "B", ExAny "C"] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [] + ] + +-- | Flags are represented somewhat strangely in the tree +-- +-- This example probably won't be in the blog post itself but as a separate +-- bug report (#3409) +dbBJ5 :: ExampleDb +dbBJ5 = [ + Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]] + , Right $ exAv "B" 1 [ExFix "D" 1] + , Right $ exAv "C" 1 [ExFix "D" 2] + , Right $ exAv "D" 1 [] + ] + +-- | Conflict sets for cycles +dbBJ6 :: ExampleDb +dbBJ6 = [ + Right $ exAv "A" 1 [ExAny "B"] + , Right $ exAv "B" 1 [] + , Right $ exAv "B" 2 [ExAny "C"] + , Right $ exAv "C" 1 [ExAny "A"] + ] + +-- | Conflicts not unique +dbBJ7 :: ExampleDb +dbBJ7 = [ + Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1] + , Right $ exAv "B" 1 [ExFix "C" 1] + , Right $ exAv "C" 1 [] + , Right $ exAv "C" 2 [] + ] + +-- | Conflict sets for SIR (C shared subgoal of independent goals A, B) +dbBJ8 :: ExampleDb +dbBJ8 = [ + Right $ exAv "A" 1 [ExAny "C"] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [] + ] + +{------------------------------------------------------------------------------- + Databases for build-tools +-------------------------------------------------------------------------------} +dbBuildTools1 :: ExampleDb +dbBuildTools1 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "A" 1 [ExBuildToolAny "alex"] + ] + +-- Test that build-tools on a random thing doesn't matter (only +-- the ones we recognize need to be in db) +dbBuildTools2 :: ExampleDb +dbBuildTools2 = [ + Right $ exAv "A" 1 [ExBuildToolAny "otherdude"] + ] + +-- Test that we can solve for different versions of executables +dbBuildTools3 :: ExampleDb +dbBuildTools3 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "alex" 2 [], + Right $ exAv "A" 1 [ExBuildToolFix "alex" 1], + Right $ exAv "B" 1 [ExBuildToolFix "alex" 2], + Right $ exAv "C" 1 [ExAny "A", ExAny "B"] + ] + +-- Test that exe is not related to library choices +dbBuildTools4 :: ExampleDb +dbBuildTools4 = [ + Right $ exAv "alex" 1 [ExFix "A" 1], + Right $ exAv "A" 1 [], + Right $ exAv "A" 2 [], + Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2] + ] + +-- Test that build-tools on build-tools works +dbBuildTools5 :: ExampleDb +dbBuildTools5 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "happy" 1 [ExBuildToolAny "alex"], + Right $ exAv "A" 1 [ExBuildToolAny "happy"] + ] + +-- Test that build-depends on library/executable package works. +-- Extracted from https://github.com/haskell/cabal/issues/3775 +dbBuildTools6 :: ExampleDb +dbBuildTools6 = [ + Right $ exAv "warp" 1 [], + -- NB: the warp build-depends refers to the package, not the internal + -- executable! + Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` ExExe "warp" [ExAny "A"], + Right $ exAv "B" 2 [ExAny "A", ExAny "warp"] + ] diff --git a/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs b/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ParallelListComp #-} +module UnitTests.Distribution.Solver.Modular.WeightedPSQ ( + tests + ) where + +import qualified Distribution.Solver.Modular.WeightedPSQ as W + +import Data.List (sort) + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (Blind(..), testProperty) + +tests :: [TestTree] +tests = [ + testProperty "'toList . fromList' preserves elements" $ \xs -> + sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs)) + + , testProperty "'toList . fromList' sorts stably" $ \xs -> + let indexAsValue :: [(Int, (), Int)] + indexAsValue = [(x, (), i) | x <- xs | i <- [0..]] + in isSorted $ W.toList $ W.fromList indexAsValue + + , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) -> + isSorted $ W.weights $ + W.mapWeightsWithKey (f :: Int -> Int -> Int) $ + W.fromList (xs :: [(Int, Int, Int)]) + + , testCase "applying 'mapWeightsWithKey' twice sorts twice" $ + let indexAsKey :: [((), Int, ())] + indexAsKey = [((), i, ()) | i <- [0..10]] + actual = W.toList $ + W.mapWeightsWithKey (\_ _ -> ()) $ + W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored + W.fromList indexAsKey + in reverse indexAsKey @?= actual + + , testProperty "'union' sorts by weight" $ \xs ys -> + isSorted $ W.weights $ + W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)])) + + , testProperty "'union' preserves elements" $ \xs ys -> + let union = W.union (W.fromList xs) + (W.fromList (ys :: [(Int, Int, Int)])) + in sort (xs ++ ys) == sort (W.toList union) + + , testCase "'lookup' returns first occurrence" $ + let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')] + in Just 'C' @?= W.lookup True xs + ] + +isSorted :: Ord a => [a] -> Bool +isSorted (x1 : xs@(x2 : _)) = x1 <= x2 && isSorted xs +isSorted _ = True